perm filename CONGEN.F4[FOO,LMM] blob sn#068172 filedate 1973-12-07 generic text, type C, neo UTF8
COMMENT āŠ—   VALID 00033 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00004 00002	C    CONGEN. COMMON AREAS.
C00011 00003	C CHOICE: DECISION ROUTINE
C00018 00004		SUBROUTINE GSCHAR (ICA)
C00019 00005		SUBROUTINE ADLINK
C00021 00006		SUBROUTINE ADBOND
C00022 00007	       SUBROUTINE BONDCL
C00025 00008	       SUBROUTINE ALTBOND (SKIP,BOND)
C00027 00009	       SUBROUTINE ALTRING (M1,M2)
C00030 00010	       SUBROUTINE EQCL (N1,N2,SYM)
C00032 00011	C DOEASY: MAIN LOOP IS HERE
C00045 00012		SUBROUTINE DELATOM
C00047 00013	       SUBROUTINE CONTIG (FROMAR,TOAR,NUM,CNT)
C00049 00014	       SUBROUTINE MINDIS (AR,NUM,MUM,MIN)
C00052 00015		SUBROUTINE NUCLEUS
C00055 00016	       SUBROUTINE GMOL (II)
C00059 00017	       SUBROUTINE MIRROR 
C00060 00018	       SUBROUTINE LINE (X1,Y1,X2,Y2,SYM)
C00064 00019	       SUBROUTINE CLRAR
C00065 00020	       SUBROUTINE GWOUT
C00068 00021	        SUBROUTINE CSRG  (MODE)
C00071 00022	       SUBROUTINE RINGGG (MODE,BRATAR,BRATC,RET)
C00078 00023	       SUBROUTINE BRANCH
C00080 00024	       SUBROUTINE WO (I17)
C00082 00025	       SUBROUTINE POSITION (CNT,STR,MODE,RET)
C00093 00026	       SUBROUTINE NDIRECT (I1,I2,I3,CNT,NDIR)
C00097 00027	       SUBROUTINE ND1 (I1,I2,I3,QAR,NDIR)
C00098 00028	       SUBROUTINE INTERSECT (I1,I2,RET)
C00101 00029	       SUBROUTINE RECPOS (LAT,NAT,RET)
C00112 00030	       SUBROUTINE UNPOS (NC)
C00114 00031	       SUBROUTINE ELIMEND
C00118 00032	       SUBROUTINE SAFMAF
C00120 00033		SUBROUTINE NMORGAN 
C00125 ENDMK
CāŠ—;
C    CONGEN. COMMON AREAS.
C 
C    ***     ***    *   *    ***    *****   *   *   
C   *   *   *   *   **  *   *   *   *       **  *   
C   *       *   *   * * *   *       *       * * *   
C   *       *   *   *  **   *       ****    *  **   
C   *       *   *   *   *   *  **   *       *   *   
C   *   *   *   *   *   *   *   *   *       *   *   
C    ***     ***    *   *    ***    *****   *   *   
C 
C 
C-------------------------------------------------------------------------------
        IMPLICIT INTEGER (A-Z)
	COMMON /CQGR/ QFLG,QPIC,QX(100),QY(100)
	COMMON /CFILLIM/ FILLIM,STRCLIM
	COMMON /CFFF/ FILEU(80),FILE(80),BLK(80),WRD(80)
     1  ,LIM(80)
	COMMON /CWHERE/ IWHERE,FCNT,PPN
	COMMON /CFFXX/ FN,IEXT,HFILEN(40)
	COMMON /CE2SW/ E2SW,E2CNT
	COMMON /CFILEN/ HNAM(14),TCH(7),FHNAM(11)
	COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
       COMMON /CLASS/ BNCNT,BNINCL(50,3)
     1  ,TERMC,TERMAT(20),TERMV(20)
     1  ,INCL,INCLA(20),INCLT(20,4)
	COMMON /CATMSOR/ ATMSOR(106)
	DATA (ATMSOR(I1),I1=1,106)/
     1   13, 15, 18, 36, 27, 11, 62, 38, 14, 55,
     1   44, 16, 37,  8,  1, 20, 89, 71, 65,  5,
     1   59, 32, 52, 51, 22, 43, 42, 41, 40, 39,
     1    6, 23,105,103, 90, 31, 87, 86, 84, 72,
     1   12, 67,  9, 64, 63, 29, 61, 60, 28, 58,
     1   57, 56, 24, 54, 53,  3, 30, 50, 49, 48,
     1   47, 46, 45,  2,106,  7,104, 25,102,101,
     1  100, 99, 98, 97, 96, 95, 94, 93, 92, 91,
     1    4, 19, 88, 26, 10, 85, 17, 83, 82, 81,
     1   80, 79, 78, 77, 76, 75, 74, 73, 21, 35,
     1   70, 69, 68, 34, 66, 33/
	COMMON /CPOSW/ POSW
       COMMON /IO/ CID,COD,E2CID,ICNT,BOD
       DATA CID,COD,E2CID /21,1,23/
C-------------------------------------------------------------------------------
C
C		THE FOLLOWING BLOCK MUST NOT BE DISTURBED
C		12,033 WORDS  
C
	COMMON /CACL/ DUM(4),NEW(1024)
       COMMON /CASA/ NUMB,AR(10,100),CDUM(3000)
	COMMON /PUSH/ PDUM(3400)
	COMMON /CRNGH/ RNGH(120)
        COMMON /INA/INA(2)
	COMMON /TRBLK/ RAR(256)
        COMMON /DDF/DDFILE(10)
	COMMON /NMOR/ NN(100),EV(100),PST(100),SA(100)
     1  ,Z(2,100),ATS(100),AT(100),ASS(100)
     1  ,SUBQ(100),SUBS(100),SUBT(100)
	COMMON /CAHA/ HOLDA(100),HOLDB(100),HOLDBB(100)
     1  ,HOLDC(100),HOLDD(100),HOLDE(100),
     1  R1MARK(100),R2MARK(100),R3MARK(100)
       COMMON /MARK/ CT(20),MK(100)
	COMMON /CEXT/ DR(10,100)
C
C
C
C-------------------------------------------------------------------------------
	COMMON /CIOMNI/ IOMNI,IOMDEV,IOFST
	COMMON /CBB/ BUFQ(2)
	DIMENSION AREQ(10)
	EQUIVALENCE (AREQ(1),AR(1,1))
       COMMON /CATAS/  ATAS(106)
       DATA (ATAS(I1),I1=1,106)/
     1  'AC','AG','AL','AM','AR','AS','AT','AU','B','BA','BE','BI',
     1  'BK','BR','C','CA','CD','CE','CF','CL','CM','CO','CR','CS',
     1  'CU','D','DY','ER','ES','EU','F','FE','FM','FR','GA','GD',
     1  'GE','H','HE','HF','HG','HO','I','IN','IR','K','KR','LA',
     1  'LI','LU','LW','MD','MG','MN','MO','N','NA','NB','ND','NE',
     1  'NI','NO','NP','O','OS','P','PA','PB','PD','PM','PO','PR',
     1  'PT','PU','RA','RB','RE','RH','RN','RU','S','SB','SC','SE',
     1  'SI','SM','SN','SR','T','TA','TB','TC','TE','TH','TI','TL',
     1  'TM','U','V','W','XE','Y','YB','ZN','ZR',' '/
	COMMON /QSCALE/ SCALE,SCC

	IOMNI=0
	IOFST=0
	IOMDEV=0
	SCC=60
	POSW=1
	QFLG=0
	E2SW=2
	BNCNT=1
	FILLIM=80
	STRCLIM=10000
	TYPE 12212

12212	FORMAT(' DCRT/NIH'/' STRUCTURE RETRIEVAL PROGRAM '
     1  /' TYPE YOUR 3 INITIALS   XXX'/)

	ACCEPT 1332,IEXT
1332	FORMAT(1A3)
	IF(IEXT .EQ. ' ') IEXT='100'

	DO 600 I1=1,4
	SST(I1)=1
	SHUNT(I1)=1
600	CONTINUE

	SHUNT(5)=1

	DO 609 I1=1,12
	FSHUNT(I1)=1
609	CONTINUE

	FSHUNT(12)=1
	SW=0
        INITF=1

	DO 70 I1=1,1000
	AREQ(I1)=0
70	CONTINUE

	NUMB=0
	CALL DOEASY
        END
C CHOICE: DECISION ROUTINE
        SUBROUTINE CHOICE (AT)
        IMPLICIT INTEGER (A-Z)
	COMMON /CREST/ LNUMB,STATE (1000)
	COMMON /CNEWHLD/ SSTATE(1000)
	COMMON /CFILLIM/ FILLIM,STRCLIM
	COMMON /CIOMNI/ IOMNI,IOMDEV,IOFST
	COMMON /CWHERE/ IWHERE,FCNT,PPN
	COMMON /CVTBAR/ VTB,DFSW
	DATA DFSW /0/
	COMMON /QSCALE/ SCALE,SCC
	COMMON /PUSH/ NEWS(1024)
	COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM,LSYM
     1  ,DELTA
	DATA LSYM /':'/
	COMMON /CATAS/ ATAS(106)
	COMMON /CGSC/ ATAR(80)
       COMMON /CLASS/ BNCNT,BNINCL(50,3)
     1  ,TERMC,TERMAT(20),TERMV(20)
     1  ,INCL,INCLA(20),INCLT(20,4)
	COMMON /MARK/ TEMP(4)
	DATA LEV /8/
	DATA TOGG /2/
	COMMON /IO/ CID,COD
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
     1  ER(6,100)
	COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
	DATA (STT(I1),I1=1,8) /
     1  'RING','STIT','STIT','SUBST',
     1  'NUC','PATT','SEQ','PATT'/
	DIMENSION AREQ (10)
	EQUIVALENCE (AREQ(1),AR(1,1))

	CALL GSCHAR (AT)
C----------------------------------------------------------------- SYM
	IF(AT .NE. 'SYM') GOTO 644
	IF(LSYM .EQ. ':') GOTO 645
	LSYM=':'
	GOTO 644
645	LSYM='*'
C----------------------------------------------------------------- MLIM
644	IF(AT .NE. 'MLIM') GOTO 416
	TYPE 417
417	FORMAT(' MAXIMUM NUMBER OF FILES TO BE MERGED ='$)
	ACCEPT 418,FILLIM
C----------------------------------------------------------------- SLIM
416	IF(AT .NE. 'SLIM') GOTO 420
	TYPE 419
419	FORMAT(' MAXIMUM NUMBER OF STRUCTURES TO BE RETRIEVED ='$)
	ACCEPT 418,STRCLIM
418	FORMAT(I)
C----------------------------------------------------------------- 
420	IF(AT .NE. 'FORCE') GOTO 700
	TERSE=2
	LSYM='*'
	SCC=40
	GOTO 701
C----------------------------------------------------------------- 
700	IF(AT .NE. 'CLEAR') GO TO 20
701	DO 600 I1=1,4
	SST(I1)=1
600	SHUNT(I1)=1

	SHUNT(5)=1
	BNCNT=1
	BNINCL(1,1)=0
	BNINCL(1,2)=0
	LNUMB=0
	TERMC=0
	INCL=0

	DO 21 I1=1,1000
	AREQ(I1)=0
	STATE(I1)=0
	SSTATE(I1)=0
21	CONTINUE

	NUMB=0
	ATHN=0
C----------------------------------------------------------------- 
20	IF(AT .EQ. 'ABOND') CALL ADBOND
	IF(AT .EQ. 'ALINK') CALL ADLINK
	IF(AT .EQ. 'NUC') CALL NUCLEUS
	IF(AT .EQ. 'SBOND') CALL BONDCL
C----------------------------------------------------------------- 
	IF(AT .NE. 'ATOM') GO TO 1221
	TYPE 111,(ATAS(I3),I3=1,106)
111	FORMAT(1X,10A3)
	TYPE 1111
1111	FORMAT(' ')
C----------------------------------------------------------------- 
1221	IF(AT .NE. 'SCALE') GO TO 532
	SCC=100-SCC
	I1=1
	IF(SCC .EQ. 60) I1=2
	TYPE 533,I1
533	FORMAT(' SCALE NOW ',1I1/)
C----------------------------------------------------------------- 
532	IF(AT .NE. 'TERMA') GO TO 222
	DO 223 I1=1,10,2
	IF(ATAR(I1) .EQ. 0) GO TO 222
	IF(TERMC .EQ. 0) GO TO 229
	DO 224 I2=1,TERMC
	IF(ATAR(I1) .EQ. TERMAT(I2)) GO TO 226
224	CONTINUE
229	CONTINUE
	TERMC=TERMC+1
	TERMAT(TERMC)=ATAR(I1)
	TERMV(TERMC)=ATAR(I1+1)
	GO TO 223
226	CONTINUE
	TERMV(I2)=ATAR(I1+1)
223	CONTINUE
	TYPE 228,(TERMAT(I1),I1=1,TERMC)
228	FORMAT(' TERMINATING ATOMS FOR ATOM BY ATOM COMPARE'/1X,20I3)
	TYPE 227,(TERMV(I1),I1=1,TERMC)
227	FORMAT(1X,20I3)
C----------------------------------------------------------------- 
222	IF(AT .NE. 'INCLA') GO TO 322
	TYPE 323
323	FORMAT(' ATOM TYPES  (4A2) ='$)
	ACCEPT 324,(TEMP(I1),I1=1,4)
324	FORMAT(4A2)
3244	FORMAT(1X,1A2,',',1A2,',',1A2,',',1A2/)
	DO 325 I1=1,10
	IF(ATAR(I1) .EQ. 0) GO TO 3322
	IF(INCL .EQ. 0) GO TO 327
	DO 326 I2=1,INCL
	IF(INCLA(I2) .EQ. ATAR(I1)) GO TO 328
326	CONTINUE
327	CONTINUE
	INCL=INCL+1
	INCLA(INCL)=ATAR(I1)
	DO 329 I2=1,4
	INCLT(INCL,I2)=TEMP(I2)
329	CONTINUE
	GO TO 325
328	CONTINUE
	DO 330 I3=1,4
	INCLT(I2,I3)=TEMP(I3)
330	CONTINUE
325	CONTINUE
3322	CONTINUE
	TYPE 332
	TYPE 331,(INCLA(I2),(INCLT(I2,I3),I3=1,4),
     1  I2=1,INCL)
332	FORMAT(' ATOM INCLUSION CLASSES FOR ATOM BY ATOM COMPARE')
331	FORMAT(1X,1I2,4A3)
C---------------------------------------------------  NO MORE
322	CONTINUE
        END
	SUBROUTINE GSCHAR (ICA)
C-------------------------------------------------------------------------------
	IMPLICIT INTEGER (A-Z)
       COMMON /IO/ CID,COD,E2CID,ICNT,BOD
	COMMON /CGSC/ ATAR(80)
	TYPE 102
102	FORMAT(' *',$)
	ACCEPT 101,ICA,(ATAR(I1),I1=1,10)
101	FORMAT(1A5,1X,10I)
	DO 10 I11=10,0,-1
	IF(ATAR(I11) .NE. 0) GO TO 11
10	CONTINUE
11	CONTINUE
	END
	SUBROUTINE ADLINK
C-------------------------------------------------------------------------------
        IMPLICIT INTEGER(A-Z)
	COMMON /CGSC/ ATAR(80)
       COMMON /CASA/ NUMB,AR(10,100)
	DO 555 I5=1,9,3
	FST=ATAR(I5)
	NUM=ATAR(I5+1)
	LEN=ATAR(I5+2)
	IF(NUM .EQ. 0) GOTO 556
	DO 21 I1=5,10
	IF(AR(I1,FST) .EQ. NUM) GO TO 555
	IF(AR(I1,FST) .EQ. 0) GO TO 23
21	CONTINUE
23	CONTINUE
	AR(I1,FST)=NUMB+1
	DO 24 I3=5,10
	IF(AR(I3,NUM) .EQ. FST) GO TO 555
	IF(AR(I3,NUM) .EQ. 0) GO TO 26
24	CONTINUE
26	CONTINUE
90	CONTINUE
	IF(LEN .EQ. 0) GO TO 555
	AR(I1,FST)=NUMB+1
	I7=NUMB+1
	DO 550 I6=1,LEN
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
550	CONTINUE
	AR(5,I7)=FST
	AR(6,NUMB)=NUM
	AR(I3,NUM)=NUMB
555	CONTINUE
556	CONTINUE
	CALL NMORGAN
	END
	SUBROUTINE ADBOND
C-------------------------------------------------------------------------------
        IMPLICIT INTEGER(A-Z)
	COMMON /CGSC/ ATAR(80)
       COMMON /CASA/ NUMB,AR(10,100)
	DO 555 I5=1,10,2
	FST=ATAR(I5)
	NUM=ATAR(I5+1)
	IF(NUM .EQ. 0) GOTO 556
	DO 21 I1=5,10
	IF(AR(I1,FST) .EQ. NUM) GO TO 90
	IF(AR(I1,FST) .EQ. 0) GO TO 23
21	CONTINUE
23	CONTINUE
	AR(I1,FST)=NUM
	DO 24 I3=5,10
	IF(AR(I3,NUM) .EQ. FST) GO TO 90
	IF(AR(I3,NUM) .EQ. 0) GO TO 26
24	CONTINUE
26	CONTINUE
	AR(I3,NUM)=FST
90	CONTINUE
555	CONTINUE
556	CONTINUE
	CALL NMORGAN
	END
       SUBROUTINE BONDCL
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
	DATA FSTSW /0/
	COMMON /IO/ CID,COD
	COMMON /CGSC/ ATAR(80)
       COMMON /CASA/ NUMB,AR(10,100)
	COMMON /CBNDST/ BNAM(15)
	DATA (BNAM(I1),I1=1,15)/
     1  'RS','RD','RT','TR','CS','CD','CT','TC',
     1  'RA','R','C','S','D','T','A'/
       COMMON /CLASS/ BNCNT,BNINCL(50,3)
90     CONTINUE
101	FORMAT(' RS=RING SINGLE   RD=RING DOUBLE'
     1  '   RT=RING TRIPLE   TR=RING TAUT'/' CS=CHAIN SINGLE'
     1  '   CD=CHAIN DOUBLE   CT=CHAIN TRIPLE   TC=CHAIN TAUT'/
     1  ' RA=RING ALTERNATING   R=RING ONLY   C=CHAIN ONLY'/
     1  ' S=ANY SINGLE   D=ANY DOUBLE   T=ANY TRIPLE   A=ANY BOND'/)
	TYPE 102
102    FORMAT(' SELECT BOND STATE')
	IF(FSTSW .GE. 1) GO TO 4646
	FSTSW=FSTSW+1
	TYPE 101
	GO TO 11
4646	CONTINUE
	TYPE 4647
4647	FORMAT(' CS CD CT TC'/' RS RD RT TR RA'/
     1  ' R  C  S  D  T  A'/)
11	CONTINUE
	ACCEPT 106,CA
106	FORMAT(1A5)
	DO 12 I1=1,15
	IF(BNAM(I1) .EQ. CA) GO TO 13
12	CONTINUE
13	CONTINUE
7576   CONTINUE
	DO 550 I5=1,10,2
	N1=ATAR(I5)
	N2=ATAR(I5+1)
	IF(N1 .EQ. 0) RETURN
       DO 58 I9=1,BNCNT-1
       IF((BNINCL(I9,1) .EQ. N1 .AND. BNINCL(I9,2) .EQ. N2)
     1 .OR. (BNINCL(I9,1) .EQ. N2 .AND. BNINCL(I9,2) .EQ. N1))
     1 GO TO 51
58     CONTINUE
       I9=BNCNT
       BNCNT=BNCNT+1
51     CONTINUE
	BNINCL(I9,1)=N1
	BNINCL(I9,2)=N2
	BNINCL(I9,3)=I1
550	CONTINUE
       END
       SUBROUTINE ALTBOND (SKIP,BOND)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
	COMMON /IO/ CID,COD
	COMMON /CGSC/ ATAR(80)
       COMMON /CASA/ NUMB,AR(10,100)
       COMMON /CLASS/ BNCNT,BNINCL(50,3)
	COMMON /PUSH/ DUM(600),MAR(20)
	DO 550 I5=1,10,2
	M1=ATAR(I5)
	M2=ATAR(I5+1)
	IF(M1 .EQ. 0) RETURN
	CALL ALTRING (M1,M2)
	DO 560 I6=1,6,SKIP
	N1=MAR(I6)
	N2=MAR(I6+1)
	IF(I6 .EQ. 6) N2=MAR(1)
       DO 58 I9=1,BNCNT-1
       IF((BNINCL(I9,1) .EQ. N1 .AND. BNINCL(I9,2) .EQ. N2)
     1 .OR. (BNINCL(I9,1) .EQ. N2 .AND. BNINCL(I9,2) .EQ. N1))
     1 GO TO 51
58     CONTINUE
       I9=BNCNT
       BNCNT=BNCNT+1
51     CONTINUE
	BNINCL(I9,1)=N1
	BNINCL(I9,2)=N2
	BNINCL(I9,3)=BOND
560	CONTINUE
550	CONTINUE
       END
       SUBROUTINE ALTRING (M1,M2)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       COMMON /CASA/ NUMB,AR(1000)
       COMMON /RNGCAR/ RNGCAR(90)
	COMMON /CPROC/ GRC,RNGC
       COMMON /PUSH/ PUSH1(500),RNGST(100),SMRAR(90),TEMAR(90)
       IC=M1
	ICC=(M1-1)*10
       ORC=1
       BRATC=0
       PC=5
10     CONTINUE
       PUSH1(1)=IC
	PUSH1(5)=ICC
       ICL=0
       I2=PC+1
       IT=1
       TEMAR(1)=IC
       SMR=1000
400    CONTINUE
C   BEGIN NEIGHBOR SEARCH
       ID=4
200    CONTINUE
       ID=ID+1
       I31=AR(ID+ICC)
       IF(I31 .EQ. 0 )GO TO 500
       IF(ID .GT. 10) GO TO 500
       IF(I31 .EQ. ICL) GO TO 200
	IF(IC .EQ. M1 .AND. I31 .NE. M2) GO TO 200
300    CONTINUE
       DO 301 I3=1,IT
       IF(TEMAR(I3) .EQ. I31) GO TO 302
301    CONTINUE
C   THIS ATOM NOT YET ON THE LIST
       IT=IT+1
       TEMAR(IT)=I31
       PUSH1(I2)=IC
       PUSH1(I2+1)=ID
       PUSH1(I2+2)=IT-1
       PUSH1(I2+3)=ICL
	PUSH1(I2+4)=ICC
       I2=I2+PC
       ICL=IC
       IC=I31
	ICC=(IC-1)*10
       GO TO 400
302    CONTINUE
       IF(I3 .NE. 1) GO TO 200
C   LOOP BACK TO STARTING POINT
       IF(IT .GE. SMR) GO TO 200
C   RING IS SMALLER   SAVE IT
       SMR=IT
       DO 304 I32=1,IT
       SMRAR(I32)=TEMAR(I32)
304    CONTINUE
       GO TO 200
500    CONTINUE
C   POP THE STACK
       I2=I2-PC
       IC=PUSH1(I2)
       ID=PUSH1(I2+1)
       IT=PUSH1(I2+2)
       ICL=PUSH1(I2+3)
	ICC=PUSH1(I2+4)
       IF(I2 .NE. 1) GO TO 200
600    CONTINUE
C   POPPED BACK TO BASE
11     CONTINUE
       END
       SUBROUTINE EQCL (N1,N2,SYM)
C-------------------------------------------------------------------------------
C A TOAD WHICH TOUTS FOR BONDCL
       IMPLICIT INTEGER (A-Z)
	COMMON /CPCHAR/ PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
	DATA FSTSW /0/
	DIMENSION BONDMAP(15)
	DATA (BONDMAP(I1),I1=1,15)/
     1  '*','+','#','%','*','+','#','%',
     1  '.','*','*','*','+','#','$'/
	COMMON /CBNDST/ BNDST(14)
       COMMON /CASA/ NUMB,AR(10,100)
       COMMON /CLASS/ BNCNT,BNINCL(50,3)
	IF(BNCNT .EQ. 1) RETURN
	IF(FSTSW .EQ. 1) GO TO 50
	FSTSW=1
	BONDMAP(1)=PSINGLE
	BONDMAP(2)=PDOUBLE
	BONDMAP(3)=PTRIPLE
	BONDMAP(4)=PTAUT
	BONDMAP(5)=PSINGLE
	BONDMAP(6)=PDOUBLE
	BONDMAP(7)=PTRIPLE
	BONDMAP(8)=PTAUT
	BONDMAP(9)=PALT
50	CONTINUE
       DO 60 I1=1,BNCNT-1
	IF(BNINCL(I1,1) .EQ. N1 .AND. BNINCL(I1,2)
     1  .EQ. N2) GO TO 61
	IF(BNINCL(I1,1) .EQ. N2 .AND.BNINCL(I1,2)
     1  .EQ. N1) GO TO 61
60     CONTINUE
	RETURN
61	CONTINUE
	I2=BNINCL(I1,3)
	SYM=BONDMAP(I2)
       END
C DOEASY: MAIN LOOP IS HERE
	SUBROUTINE DOEASY
        IMPLICIT INTEGER (A-Z)
	COMMON /CQGR/ QFLG,QPIC,QX(100),QY(100)
	COMMON /CNEWHLD/ SSTATE(1000)
	COMMON /CWHERE/ IWHERE,FCNT,PPN
	COMMON /CFFXX/ FN,IEXT,HFILEN(40)
       COMMON /CLASS/ BNCNT,BNINCL(50,3)
     1  ,TERMC,TERMAT(20),TERMV(20),INCL,INCLA(20),INCLT(20,4)
	COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
     1  ,LSYM,DELTA
	COMMON /CGSC/ ATAR(80)
       COMMON /CACL/ EKC,UPB,WC,ICC,CARCL(1000)
       COMMON /CMI/ DUMCR(106),DUMAT(106),MATX(40),CONX(40),
     1 CONXT(6),ATXT(6),ATX(6,40),RCBX(6,40),CC,AACNT(40)
     1  ,REGA(10),P(25),LEVEL(12)
	COMMON /CSTRC/ STRCNT(11)
	COMMON /CAUTO/ IAUTO,IPROP,ICSTAR,IPREVF,IPREVR
	COMMON /CL4INT/ ISOCNT
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
     1  ER(6,100)
	COMMON /CREST/ LNUMB,STATE (1000)
	DIMENSION AREQ(10)
	EQUIVALENCE (AREQ(1),AR(1,1))
	COMMON /IO/ CID,COD
	COMMON /CSST/ SW,SST(4),STT(8),SHUNT(5),FSHUNT(12)
	EQUIVALENCE (PROBE,SW)
C----------------------------------------------------------------- 
	TERSE=1
	TERMC=0
	INCL=0
	ATHN=0
	DELTA=1
	BENDARM=2
	LNUMB=0
	NUMB=0

	DO 66621 I1=1,1000
	AREQ(I1)=0
66621	CONTINUE

20	CALL CHOICE (AT)

	DO 7183 I1=1,1000
	STATE(I1)=AREQ(I1)
7183	CONTINUE

	LNUMB=NUMB
C----------------------------------------------------------------- 
	IF(NUMB .EQ. 0 .OR. AT .NE. 'D') GO TO 21
	DO 86 I1=1,1000
	SSTATE(I1)=AREQ(I1)
86	CONTINUE

	LLNUMB=NUMB
	CALL CSRG (2)
C   MODE 0 FOR NO NUMBERS IN GMOL  MODE 2 FOR NUMBERS
	CALL GMOL (0)
	QFLG=0
	GOTO 20
C----------------------------------------------------------------- 
21	IF(NUMB .EQ. 0 .OR. AT .NE. 'Q') GO TO 921
	DO 986 I1=1,1000
	SSTATE(I1)=AREQ(I1)
986	CONTINUE
	LLNUMB=NUMB
	CALL CSRG (2)
C   MODE 0 FOR NO NUMBERS IN GMOL  MODE 2 FOR NUMBERS
	CALL GMOL (0)
	GOTO 20
C----------------------------------------------------------------- 
921	ATHN=NUMB
	IF(AT .NE. 'REST') GO TO 80
7175	CONTINUE
C   RESTORE THE STRUCTURE TO THE PREVIOUS STATE
	QFLG=0
	DO 85 I1=1,1000
	AREQ(I1)=SSTATE(I1)
85	CONTINUE
	NUMB=LLNUMB
	ATHN=LLNUMB
	GO TO 20
C----------------------------------------------------------------- 
80	CONTINUE
230	CONTINUE
	IF(AT .NE. 'DATOM') GOTO 5111
	CALL DELATOM
	GOTO 20
C----------------------------------------------------------------- 
5111	CONTINUE
	IF(AT .NE. 'MORGA') GOTO 5112
	CALL NMORGAN
	GOTO 20
C----------------------------------------------------------------- 
5112	CONTINUE
	IF(AT .EQ. 'ALTBD') CALL ALTBOND (1,9)
	IF(AT .EQ. 'WISBD') CALL ALTBOND (2,6)
C----------------------------------------------------------------- 
	IF(AT .NE. 'AATOM') GO TO 660
	DO 3232 I2=1,10,2
	I3=ATAR(I2)
	I4=ATAR(I2+1)
	IF(I3 .EQ. 0 .OR. I4 .EQ. 0) GO TO 20
	NUMB=NUMB+1
	DO 661 I1=5,10
	IF(AR(I1,I3) .EQ. I4) GO TO 662
661	CONTINUE
	GO TO 20
662	CONTINUE
	AR(I1,I3)=NUMB
	DO 663 I1=5,10
	IF(AR(I1,I4) .EQ. I3) GO TO 664
663	CONTINUE
	GO TO 20
664	CONTINUE
	AR(I1,I4)=NUMB
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=I3
	AR(6,NUMB)=I4
3232	CONTINUE
	GO TO 20
C----------------------------------------------------------------- 
660	CONTINUE
	IF(AT .NE. 'DBOND') GO TO 670
	I2=ATAR(1)
	I3=ATAR(2)
	IF(I2 .EQ. 0 .OR. I3 .EQ. 0) GOTO 20
	DO 671 I1=5,10
	IF(AR(I1,I2) .EQ. I3) GO TO 672
671	CONTINUE
672	CONTINUE
	I4=I1
	DO 673 I5=I1+1,10
	AR(I4,I2)=AR(I5,I2)
	I4=I4+1
	AR(I5,I2)=0
673	CONTINUE
	DO 674 I1=5,10
	IF(AR(I1,I3) .EQ. I2) GO TO 675
674	CONTINUE
675	CONTINUE
	I4=I1
	DO 676 I5=I1+1,10
	AR(I4,I3)=AR(I5,I3)
	I4=I4+1
	AR(I5,I3)=0
676	CONTINUE
	GO TO 20
C----------------------------------------------------------------- 
670	CONTINUE
	IF(AT .NE. 'SATOM') GO TO 200
	TYPE 211
211	FORMAT(' ATOM TYPE ='$)
	ACCEPT 212,CA
212	FORMAT(1A5)
	DO 210 I1=1,10
	I2=ATAR(I1)
	IF(I2 .EQ. 0) GO TO 20
	IF(I2 .GT. NUMB) GO TO 210
	AR(2,I2)=CA
	IF(CA .EQ. 'C') AR(2,I2)=0
210	CONTINUE
	GO TO 20
C----------------------------------------------------------------- 
200	CONTINUE
	IF(AT .NE. 'SPIRO') GO TO 6060
	DO 6061 I2=1,10,2
	STNUM=ATAR(I2)
	FINNUM=STNUM
	EXTN=ATAR(I2+1)
	IF(STNUM .EQ. 0 .OR. FINNUM .EQ. 0) GO TO 20
	DO 6201 I1=5,10
	IF(AR(I1,STNUM) .EQ. 0) GO TO 6202
6201	CONTINUE
6202	CONTINUE
	AR(I1,STNUM)=NUMB+1
	I3=NUMB+1
	DO 6203 I1=1,EXTN
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
6203	CONTINUE
	AR(5,I3)=STNUM
	AR(6,NUMB)=FINNUM
	DO 6204 I1=5,10
	IF(AR(I1,FINNUM) .EQ. 0) GO TO 6205
6204	CONTINUE
6205	CONTINUE
	AR(I1,FINNUM)=NUMB
6061	CONTINUE
	GO TO 20
C----------------------------------------------------------------- 
6060	CONTINUE
	IF(AT .NE. 'ARING') GO TO 90
	DO 2040 I2=1,10,2
	STNUM=ATAR(I2)
	FINNUM=ATAR(I2+1)
	IF(STNUM .EQ. 0 .OR. FINNUM .EQ. 0) GO TO 20
	DO 201 I1=5,10
	IF(AR(I1,STNUM) .EQ. 0) GO TO 202
201	CONTINUE
202	CONTINUE
	IF(STNUM .NE. FINNUM) GO TO 7060
	EXTN=5
	GO TO 300
7060	CONTINUE
	CALL MINDIS (AR,STNUM,FINNUM,DIF)
C   IF THE TWO NODES ARE IN DIFFERENT STRUCTURES JUST BOND THEM TOGETHER
	IF(DIF .EQ. 0) GO TO 303
	EXTN=6-DIF
	IF(EXTN .NE. 0) GO TO 300
303	CONTINUE
C   JUST ADD BOND TO FORM RING
	AR(I1,STNUM)=FINNUM
	DO 301 I1=5,10
	IF(AR(I1,FINNUM) .EQ. 0) GO TO 302
301	CONTINUE
302	CONTINUE
	AR(I1,FINNUM)=STNUM
	GO TO 2040
300	CONTINUE
	AR(I1,STNUM)=NUMB+1
	I3=NUMB+1
	DO 203 I1=1,EXTN
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
203	CONTINUE
	AR(5,I3)=STNUM
	AR(6,NUMB)=FINNUM
	DO 204 I1=5,10
	IF(AR(I1,FINNUM) .EQ. 0) GO TO 205
204	CONTINUE
205	CONTINUE
	AR(I1,FINNUM)=NUMB
2040	CONTINUE
	GO TO 20
C----------------------------------------------------------------- 
90	CONTINUE
	IF(AT .NE. 'CRING') GO TO 590
	DO 5040 I2=1,10,2
	STNUM=ATAR(I2)
	EXTN=ATAR(I2+1)
	IF(EXTN .EQ. 0) EXTN=6
	IF(STNUM .EQ. 0) GO TO 20
	DO 509 I1=5,10
	IF(AR(I1,STNUM) .EQ. 0) GO TO 508
509	CONTINUE
508	CONTINUE
	AR(I1,STNUM)=NUMB+1
	I3=NUMB+1
	EXTN=EXTN-1
	DO 503 I1=1,EXTN
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
503	CONTINUE
	AR(5,I3)=STNUM
	AR(6,NUMB)=STNUM
	DO 504 I1=5,10
	IF(AR(I1,STNUM) .EQ. 0) GO TO 505
504	CONTINUE
505	CONTINUE
	AR(I1,STNUM)=NUMB
5040	CONTINUE
	GO TO 20
C----------------------------------------------------------------- 
590	CONTINUE
	IF(AT .NE. 'ABRAN') GO TO 240
	DO 2050 I2=1,10,2
	STNUM=ATAR(I2)
	NN=ATAR(I2+1)
	IF(STNUM .EQ. 0) GO TO 20
	I3=NUMB+1
	DO 242 I1=1,NN
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
242	CONTINUE
	AR(5,I3)=STNUM
	AR(6,NUMB)=0
	DO 243 I1=5,10
	IF(AR(I1,STNUM) .EQ. 0) GO TO 244
243	CONTINUE
244	CONTINUE
	AR(I1,STNUM)=I3
2050	CONTINUE
	GO TO 20
C----------------------------------------------------------------- 
240	CONTINUE
	IF(AT .NE. 'CHAIN') GO TO 260
	NN=ATAR(1)
	I3=NUMB+1
	DO 262 I1=1,NN
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
262	CONTINUE
	AR(5,I3)=AR(6,I3)
	AR(6,I3)=0
	AR(6,NUMB)=0
	GO TO 20
C----------------------------------------------------------------- 
260	CONTINUE
	IF(AT .NE. 'RING') GO TO 261
C   LOOP CLOSES   PUT IN RING
	I3=NUMB+1
	DO 221 I1=1,6
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
221	CONTINUE
	AR(5,I3)=NUMB
	AR(6,NUMB)=I3
	GO TO 20
C----------------------------------------------------------------- 
261	CONTINUE
	IF(AT .NE. 'C') GOTO 9264
	DO 9265 I1=1,NUMB
	DO 9266 I2=10,5,-1
	IF(AR(I2,I1) .NE. 0) GOTO 9267
9266	CONTINUE
9267	CONTINUE
	I4=AR(2,I1)
	IF(I4 .EQ. 0) I4='C'
	TYPE 9268,I1,I4,(AR(I3,I1),I3=5,I2)
9268	FORMAT(1I3,1X,1A2,1X,6I3)
9265	CONTINUE
	GOTO 20
C----------------------------------------------------------------- 
9264	CONTINUE
	REREAD 9262,IBIB
9262	FORMAT(1A3)
	GOTO 20
	END
	SUBROUTINE DELATOM
C-------------------------------------------------------------------------------
        IMPLICIT INTEGER (A-Z)
	COMMON /CGSC/ ATAR(80)
       COMMON /CASA/ NUMB,AR(10,100),BR(10,100)
	DIMENSION AREQ(10),BREQ(10)
	EQUIVALENCE (AREQ(1),AR(1,1))
	EQUIVALENCE (BREQ(1),BR(1,1))
	DO 90 I9=1,10
	NUM=ATAR(I9)
	IF(NUM .EQ. 0) GO TO 91
	DO 10 I1=5,10
	IF(AR(I1,NUM) .EQ. 0) GO TO 11
10	CONTINUE
11	CONTINUE
	I1=I1-5
	IF(I1 .EQ. 2) GO TO 30
	IF(I1 .NE. 1) GO TO 90
C   ONE NEIGHBOR NODE   DELETE IT
	I2=AR(5,NUM)
	DO 41 I1=5,10
	IF(AR(I1,I2) .EQ. NUM) GO TO 42
41	CONTINUE
42	CONTINUE
	AR(5,NUM)=0
	AR(I1,I2)=0
	IF(NUM .EQ. NUMB) NUMB=NUMB-1
	AR(1,NUM)=0
	AR(2,NUM)=0
	GO TO 90
30	CONTINUE
	I2=AR(5,NUM)
	I4=AR(6,NUM)
	DO 20 I3=5,10
	IF(AR(I3,I2) .EQ. NUM) GO TO 21
20	CONTINUE
21	CONTINUE
	AR(I3,I2)=I4
	DO 25 I3=5,10
	IF(AR(I3,I4) .EQ. NUM) GO TO 26
25	CONTINUE
26	CONTINUE
	AR(I3,I4)=I2
	AR(1,NUM)=0
	AR(2,NUM)=0
90	CONTINUE
91	CONTINUE
	DO 105 I3=1,NUMB
	IF(AR(1,I3) .NE. 0) GOTO 106
105	CONTINUE
106	CONTINUE
	CALL CONTIG (AR,BR,I3,NUMB)
	I3=NUMB*10
	DO 310 I1=1,I3
	AREQ(I1)=BREQ(I1)
310	CONTINUE
	END
       SUBROUTINE CONTIG (FROMAR,TOAR,NUM,CNT)
C-------------------------------------------------------------------------------
C   WORD 3 OF EACH ATOM IS USED TO DENOTE WHETHER RING OR BRANCH
C   1 IS BRANCH   0 IS RING
       IMPLICIT INTEGER (A-Z)
        DIMENSION FROMAR(10,100),TOAR(10,100)
       COMMON /MARK/ CT(20),MK(100)
       CT(1)=NUM
       CT(2)=0
       CTC=2
       DO 9 I1=1,100
       MK(I1)=0
9      CONTINUE
20     CONTINUE
       DO 10 I1=1,20
       I4=CT(I1)
       IF(I4 .EQ. 0) GO TO 50
       DO 30 I2=5,10
       I3=FROMAR(I2,I4)
       IF(I3 .EQ. 0) GO TO 30
       IF(MK(I3) .NE. 0) GO TO 30
       MK(I3)=1
       CT(CTC)=I3
       CTC=CTC+1
       IF(CTC .GE. 21) CTC=1
       CT(CTC)=0
30     CONTINUE
10     CONTINUE
       GO TO 20
50     CONTINUE
	CNT=0
	DO 60 I1=1,100
	IF(MK(I1) .EQ. 0) GO TO 60
	CNT=CNT+1
	MK(I1)=CNT
60	CONTINUE
	ICNT=0
	DO 70 I1=1,100
	IF(MK(I1) .EQ. 0) GO TO 70
	ICNT=ICNT+1
	TOAR(1,ICNT)=MK(I1)
	TOAR(2,ICNT)=FROMAR(2,I1)
	TOAR(3,ICNT)=FROMAR(3,I1)
	TOAR(4,ICNT)=0
	I6=5
	DO 71 I2=5,10
	I3=FROMAR(I2,I1)
	TOAR(I2,ICNT)=0
	IF(I3 .EQ. 0) GO TO 71
	IF(MK(I3) .EQ. 0) GO TO 71
	TOAR(I6,ICNT)=MK(I3)
	I6=I6+1
71	CONTINUE
70	CONTINUE
	END
       SUBROUTINE MINDIS (AR,NUM,MUM,MIN)
C-------------------------------------------------------------------------------
C
C   FINDS THE MINIMUM DISTANCE BETWEEN TWO NODES  NUM AND MUM
C
C   IN PUSH1    WD1=ATOM POINTER   WD2=NEIGHBOR   WD3=NEXT PLACE TO STORE ATOM
C     IN TEMAR
       IMPLICIT INTEGER (A-Z)
       DIMENSION AR(10,50)
       COMMON /PUSH/ PUSH1(500),TEMAR(90)
C   TRY TO SHORT CIRCUIT MINDIS   SEE IF MUM IS FIRST NEIGHBOR OF NUM
	DO 700 IC=5,10
	IF(AR(IC,NUM) .NE. MUM) GO TO 700
C   MUM IS FIRST NEIGHBOR
	MIN=2
	RETURN
700	CONTINUE
       IC=NUM
       ORC=1
       BRATC=0
       PC=4
10     CONTINUE
       PUSH1(1)=IC
       ICL=0
       I2=PC+1
       IT=1
       TEMAR(1)=IC
       MIN=10000
400    CONTINUE
C   BEGIN NEIGHBOR SEARCH
       ID=4
200    CONTINUE
       ID=ID+1
       I31=AR(ID,IC)
       IF(I31 .EQ. 0 )GO TO 500
       IF(ID .GT. 10) GO TO 500
       IF(I31 .EQ. ICL) GO TO 200
	IF(I31 .EQ. MUM) GO TO 302
300    CONTINUE
       DO 301 I3=1,IT
       IF(TEMAR(I3) .EQ. I31) GO TO 200
301    CONTINUE
C   THIS ATOM NOT YET ON THE LIST
       IT=IT+1
       TEMAR(IT)=I31
       PUSH1(I2)=IC
       PUSH1(I2+1)=ID
       PUSH1(I2+2)=IT-1
       PUSH1(I2+3)=ICL
       I2=I2+PC
       ICL=IC
       IC=I31
       GO TO 400
302    CONTINUE
C   FOUND A SMALLER DISTANCE BETWEEN THE TWO NODES
       IF(IT .GE. MIN) GO TO 200
C   DISTANCE IS SMALLER   SAVE IT
       MIN=IT
       GO TO 200
500    CONTINUE
C   POP THE STACK
       I2=I2-PC
       IC=PUSH1(I2)
       ID=PUSH1(I2+1)
       IT=PUSH1(I2+2)
       ICL=PUSH1(I2+3)
       IF(I2 .NE. 1) GO TO 200
600    CONTINUE
C   POPPED BACK TO BASE
	MIN=MIN+1
       END
	SUBROUTINE NUCLEUS
C-------------------------------------------------------------------------------
        IMPLICIT INTEGER (A-Z)
	COMMON /IO/ CID,COD
	COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
	COMMON /CASA/ NUMB,AR(10,100)
	COMMON /CGSC/ ATAR(80)
	TYPE 101
101	FORMAT('+*'$)
	ACCEPT 102,(ATAR(I1),I1=1,20)
1022	FORMAT(1X,20A1)
102	FORMAT(20A1)
	DO 10 I1=1,20
	I2=ATAR(I1)
	IF(I2 .EQ. ' ') GO TO 11
	IF(I2 .NE. 'U') GO TO 20
	ILL=IUL
	IUL=IUL-1
	GO TO 10
20	CONTINUE
	IF(I2 .NE.'D') GO TO 21
	IUL=ILL
	ILL=ILL+1
	GO TO 10
21	CONTINUE
	DECODE (1,103,I2)IR
103	FORMAT(1I1)
	IF(IR .LT. 3 .OR. IR .GT. 7) GO TO 10
	IF(I1 .NE. 1) GO TO 30
	I4=NUMB+1
	DO 221 I3=1,IR
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
221	CONTINUE
	AR(5,I4)=NUMB
	AR(6,NUMB)=I4
	IUL=I4
	ILL=NUMB
	GO TO 10
30	CONTINUE
	DO 31 I3=5,10
	IF(AR(I3,IUL) .EQ. 0) GO TO 32
31	CONTINUE
32	CONTINUE
	AR(I3,IUL)=NUMB+1
	EXTN=IR-2
	I4=NUMB+1
	DO 40 I3=1,EXTN
	NUMB=NUMB+1
	AR(1,NUMB)=NUMB
	AR(2,NUMB)=0
	AR(5,NUMB)=NUMB-1
	AR(6,NUMB)=NUMB+1
40	CONTINUE
	AR(5,I4)=IUL
	AR(6,NUMB)=ILL
	DO 51 I3=5,10
	IF(AR(I3,ILL) .EQ. 0) GO TO 52
51	CONTINUE
52	CONTINUE
	AR(I3,ILL)=NUMB
	IUL=I4+(EXTN/2)-1
	ILL=I4+(EXTN/2)
10	CONTINUE
11	CONTINUE
	END
       SUBROUTINE GMOL (II)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
	COMMON /CREGNO/ REGNO
       COMMON /IO/ CID,COD,E2CID
	COMMON /CPCHAR/ PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
	DATA PSINGLE,PDOUBLE,PTRIPLE,PALT,PTAUT
     1   /'*','+','#','.','%'/
	COMMON /CMIRSUP/ MIRSUP
	DATA MIRSUP /0/
	DATA ERCNT /0/
	COMMON /CACL/ DUMM(4),BND(10,100)
	COMMON /CATAS/ ATAS(106)
       COMMON /MD/ MDX,MDY
       COMMON /CASA/ NUMB,AR(10,100),ARP(100,1)
	DATA DCON /20/
	DATA DOFF /25/
       DIMENSION PT(5)
	COMMON /CE2SW/ E2SW,E2CNT
	COMMON /CIOMNI/ IOMNI,IOMDEV
	IF(E2CNT .EQ. 0 .OR. E2SW .EQ. 1) GO TO 300
	ERCNT=ERCNT+1
	RETURN
300	CONTINUE
	CALL CLRAR
       MINX=10000
       MINY=10000
       MAXX=0
       MAXY=0
       DO 80 I1=1,NUMB
       I2=AR(3,I1)
       I3=AR(4,I1)
       IF(I2 .GT. MAXX)MAXX=I2
       IF(I2 .LT. MINX) MINX=I2
       IF(I3 .GT. MAXY) MAXY=I3
       IF(I3 .LT. MINY) MINY=I3
80     CONTINUE
       IF(((MAXY-MINY)-(MAXX-MINX)) .LT. 10) GO TO 81
       IF(MIRSUP .EQ. 0) CALL MIRROR
81     CONTINUE
       DO 10 I1=1,NUMB
       IF(AR(3,I1) .EQ. 0 .OR. AR(4,I1) .EQ. 0) GO TO 11
       I2=(AR(3,I1)/DCON)+DOFF
       I3=(AR(4,I1)/DCON)+DOFF
	I99=AR(2,I1)
	IF(II .NE. 2) GO TO 70
	CALL QPACN (I99,PT,5)
	ARP(I2,I3)=PT(1)
	IF(PT(2) .NE. ' ') ARP(I2+1,I3)=PT(2)
	GO TO 71
70	CONTINUE
	IF(I99 .EQ. 0) I99=' '
	ENCODE (5,101,PTT) I1,I99
101	FORMAT(1I2,1A2)
	CALL QPACN (PTT,PT,5)
	I21=1
	IF(PT(1) .EQ. ' ') I21=2
	I22=5
	IF(PT(4) .EQ. ' ') I22=3
	IF(PT(3) .EQ. ' ') I22=2
	DO 90 I11=I21,I22
	ARP(I2+I11-I21,I3)=PT(I11)
90	CONTINUE
71	CONTINUE
	DO 20 I4=5,10
	I55=AR(I4,I1)
       IF(I55 .EQ. 0) GO TO 60
       IF(I55 .LT. I1) GO TO 20
       I10=(AR(3,I55)/DCON)+DOFF
       I11=(AR(4,I55)/DCON)+DOFF
	SYM=PSINGLE
	IF(II .EQ. 2) GO TO 510
	CALL EQCL (I1,I55,SYM)
	GO TO 50
510	CONTINUE
	IB=BND(I4,I1)
	IF(IB .EQ. 2 .OR. IB .EQ. 6) SYM=PDOUBLE
	IF(IB .EQ. 3 .OR. IB .EQ. 7) SYM=PTRIPLE
	IF(IB .EQ. 4 .OR. IB .EQ. 8) SYM=PTAUT
	IF(IB .EQ. 9) SYM=PALT
50     CONTINUE
       CALL LINE (I2,I3,I10,I11,SYM)
20	CONTINUE
60     CONTINUE
10     CONTINUE
       CALL GWOUT
	RETURN
11	CONTINUE
	ERCNT=ERCNT+1
       END
       SUBROUTINE MIRROR 
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       COMMON /CASA/ NUMB,MOLLY(10,100)
       DO 31 I2=1,NUMB
       IX=MOLLY(3,I2)
       IY=MOLLY(4,I2)
       MOLLY(3,I2)=IY
       MOLLY(4,I2)=IX
31     CONTINUE
       END
       SUBROUTINE LINE (X1,Y1,X2,Y2,SYM)
C-------------------------------------------------------------------------------
C DRAW ANY HORIZ,VERT OR DIAG LINE
       IMPLICIT INTEGER (A-Z)
	COMMON /CVTBAR/ VTB,DFSW
	COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM,LSYM
       COMMON /CASA/ DDD(1001),AR(100,1)
       COMMON /MD/ MDX,MDY
       DATA MDX,MDY /100,100/
	DATA BKSL,VTBAR /"560000000000,"760000000000/
	IF(X1 .EQ. 0 .OR. Y1 .EQ. 0 .OR. X2 .EQ. 0 .OR. Y2 .EQ. 0)
     1  CALL WO ('LINE')
       IF(Y1 .EQ. Y2) GO TO 10
       IF(X1 .NE. X2) GO TO 20
	IF(SYM .EQ. LSYM .AND. VTB .EQ. 1) SYM=VTBAR
	IF(SYM .EQ. LSYM .AND. VTB .EQ. 0) SYM='ā†‘'
       IF(Y1 .LE. Y2) GO TO 1
       TY1=Y2
       TY2=Y1
       GO TO 2
1      CONTINUE
       TY1=Y1
       TY2=Y2
2      CONTINUE
       DO 30 I1=TY1,TY2
       IF(I1 .GT. MDY .OR. I1 .LT. 1) GO TO 30
       IF(AR(X1,I1) .NE. ' ') GO TO 30
       AR(X1,I1)=SYM
30     CONTINUE
       RETURN
20     CONTINUE
       I4=IABS(X1-X2)   +1
       TX1=X1
       TY1=Y1
       TY2=Y2
       IF(X1 .LT. X2) GO TO 21
       TX1=X2
       TY1=Y2
       TY2=Y1
21     CONTINUE
       IF(TY1 .GT. TY2) GO TO 22
	IF(SYM .EQ. LSYM) SYM='/'
       DO 50 I1=1,I4
       I6=TX1-1+I1
       I7=TY1-1+I1
       IF(I7 .GT. TY2) I7=TY2
       IF(I6 .GT. MDX .OR. I6 .LT. 1 .OR. I7 .GT. MDY .OR. I7 .LT.1)
     1    GO TO 50
       IF(AR(I6,I7) .NE. ' ') GO TO 50
       AR(I6,I7)=SYM
50     CONTINUE
       RETURN
22     CONTINUE
	IF(SYM .EQ. LSYM) SYM=BKSL
       DO 51 I1=1,I4
       I6=TX1-1+I1
       I7=TY1+1-I1
       IF(I7 .LT. TY2) I7=TY2
       IF(I6 .GT. MDX .OR. I6 .LT. 1 .OR. I7 .GT. MDY .OR. I7 .LT.1)
     1    GO TO 51
       IF(AR(I6,I7) .NE. ' ') GO TO 51
       AR(I6,I7)=SYM
51     CONTINUE
       RETURN
10     CONTINUE
	IF(SYM .EQ. LSYM) SYM='-'
       IF(X1 .LE. X2) GO TO 11
       TX1=X2
       TX2=X1
       GO TO 12
11     CONTINUE
       TX1=X1
       TX2=X2
12     CONTINUE
       DO 40 I1=TX1,TX2
       IF(I1 .GT. MDX .OR. I1 .LT. 1) GO TO 40
       IF(AR(I1,Y1) .NE. ' ') GO TO 40
       AR(I1,Y1)=SYM
40     CONTINUE
       END
       SUBROUTINE CLRAR
C-------------------------------------------------------------------------------
C CLEAR THE PRINTOUT ARRAY
       IMPLICIT INTEGER (A-Z)
       COMMON /CASA/ DDDD(1001),AR(10)
       COMMON /MD/ MDX,MDY
       I2=MDX*MDY
       DO 10 I1=1,I2
       AR(I1)=' '
10     CONTINUE
       END
       SUBROUTINE GWOUT
C-------------------------------------------------------------------------------
C WRITES OUT THE GRAPH IMAGE
       IMPLICIT INTEGER (A-Z)
	DATA I111 /0/
	COMMON /CREGNO/ REGNO
       COMMON /IO/ CID,COD
       COMMON /CASA/ DDDD(1001),AR(100,1)
       DIMENSION ARE(1)
       EQUIVALENCE (AR(1,1),ARE(1))
       COMMON /MD/ MDX,MDY
       DATA YLEN /1/
	I111=I111+1
       XMAX=0
       YMAX=0
       XMIN=MDX
       YMIN=MDY
       I12=MDX*MDY
       DO 10 I11=1,I12
       IF(ARE(I11) .EQ. ' ') GO TO 10
       I2=MOD(I11,MDX)
       IF(I2 .EQ. 0) I2=MDX
       I1=(I11/MDX)+1
       IF(I2 .GT. XMAX) XMAX=I2
       IF(I2 .LT. XMIN) XMIN=I2
       IF(I1 .GT. YMAX) YMAX=I1
       IF( I1 .LT. YMIN) YMIN=I1
10     CONTINUE
       XMAX=XMAX+YLEN
       YMAX=YMAX+YLEN
       XMIN=XMIN-YLEN
       YMIN=YMIN-YLEN
       IF( XMIN .LT. 1 ) XMIN=1
       IF(YMIN .LT. 1) YMIN=1
       IF(XMAX .GT. MDX) XMAX=MDX
       IF(YMAX .GT. MDY) YMAX=MDY
       DO 30 I1=YMAX,YMIN,-1
       I3=XMAX
       DO 31 I4=XMIN,XMAX
       IF(AR(I3,I1) .NE. ' ') GO TO 32
       I3=I3-1
31     CONTINUE
32     CONTINUE
       WRITE(5,101)(AR(I2,I1),I2=XMIN,I3)
       DO 40 I47=XMIN,I3
       AR(I47,I1)=' '
40     CONTINUE
30     CONTINUE
101    FORMAT(' ',130A1)
       END
        SUBROUTINE CSRG  (MODE)
       IMPLICIT INTEGER (A-Z)
       COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
       COMMON /RECC/ RECCNT,RECLIM
	COMMON /CE2SW/ E2SW,E2CNT
       COMMON /CDQCS/ DQCSRG
	COMMON /CSEQ/ SEQ(100),MSEQ(100)
       COMMON /ACARR/ ACAR(80)
       COMMON /FRDIR/ FRDIR
       COMMON /OTHRING/ ORC,ORING(100)
       COMMON /RNGGR/ RNGGR
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
     1   ER(6,100),BNDH(6,100)
       DIMENSION AREQ(10)
       EQUIVALENCE (AREQ(1),AR(1,1))
       DIMENSION EREQ(10)
       EQUIVALENCE (EREQ(1),ER(1,1))
       DIMENSION BREQ(10)
       EQUIVALENCE (BREQ(1),BR(1,1))
       COMMON /STPOS/ STPOS
       COMMON /CPOSW/ POSW
       COMMON /IO/ CID,COD
        DATA COD /1/
       COMMON /QSCALE/ SCALE,SCC
	DATA SCC /80/
       DATA SCALE /60/
       DIMENSION RINGT(100)

	E2CNT=0
	SCALE=SCC
	P1LIM=990
	P2LIM=1990
	P3LIM=290
	RECLIM=40

	DO 90 I1=1,NUMB
	AR(4,I1)=I1
90	CONTINUE

       	IF(MODE .EQ. 1) CALL NMORGAN

       DO 900 I1=1,NUMB
	SEQ(I1)=AR(3,I1)
	MSEQ(I1)=AR(4,I1)
	AR(4,I1)=0
       AR(3,I1)=0
	DO 91 I2=5,10
	BNDH(I2-4,I1)=AR(I2,I1)
91	CONTINUE
900    CONTINUE

       I13=NUMB*6

       DO 12 I1=1,I13
       BREQ(I1)=0
       BREQ(I1+600 )=0
       BREQ(I1+1200)=0
       BREQ(I1+1800)=0
       EREQ(I1)=0
12     CONTINUE

       AR(3,1)=500
       AR(4,1)=500
       STPOS=0
       FRDIR=0

       CALL SAFMAF

       CALL ELIMEND

       CALL RINGGG (0,RINGT,CRINGT,RET)

       CALL BRANCH

       DO 1047 I1=1,100
       ORING(I1)=0
1047   CONTINUE

       ORC=1

	DO 92 I1=1,NUMB
	AR(1,I1)=I1
	DO 93 I2=5,10
	AR(I2,I1)=BNDH(I2-4,I1)
93	CONTINUE
92	CONTINUE

       END
       SUBROUTINE RINGGG (MODE,BRATAR,BRATC,RET)
C-------------------------------------------------------------------------------
C   IN PUSH1    WD1=ATOM POINTER   WD2=NEIGHBOR   WD3=NEXT PLACE TO STORE ATOM
C     IN TEMAR
       IMPLICIT INTEGER (A-Z)
       COMMON /RECC/ RECCNT,RECLIM
       DIMENSION BRATAR(10)
       COMMON /OTHRING/ ORC,ORING(100)
       COMMON /PUSH/ PUSH1(1000),PUSH2(2000),PUSH3(300)
       COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
	COMMON /ARCC/ SMRAR(90),TEMAR(90)
       IC=0
       ORC=1
       BRATC=0
       IF(MODE .NE. 0) IC=MODE-1
       PC=4
10     CONTINUE
       IC=IC+1
       IF(IC .GT. NUMB) GO TO 11
       IF(AR(1,IC) .GT. 100) GO TO 10
       PUSH1(1)=IC
       ICL=0
       I2=PC+1
       IT=1
       TEMAR(1)=IC
       SMR=1000
400    CONTINUE
C   BEGIN NEIGHBOR SEARCH
       ID=4
200    CONTINUE
       ID=ID+1
       I31=AR(ID,IC)
       IF(I31 .GT. 100) GO TO 200
       IF(I31 .EQ. 0 )GO TO 500
       IF(ID .GT. 10) GO TO 500
       IF(I31 .EQ. ICL) GO TO 200
300    CONTINUE
       DO 301 I3=1,IT
       IF(TEMAR(I3) .EQ. I31) GO TO 302
301    CONTINUE
C   THIS ATOM NOT YET ON THE LIST
       IT=IT+1
       TEMAR(IT)=I31
       PUSH1(I2)=IC
       PUSH1(I2+1)=ID
       PUSH1(I2+2)=IT-1
       PUSH1(I2+3)=ICL
       I2=I2+PC
       IF(I2 .LE. P1LIM) GO TO 5051
       TYPE 5052
5052   FORMAT(' PUSH1 OVERFLOW'/)
       RECCNT=1000000
       RETURN
5051   CONTINUE
       ICL=IC
       IC=I31
       GO TO 400
302    CONTINUE
       IF(I3 .NE. 1) GO TO 200
C   LOOP BACK TO STARTING POINT
       IF(IT .GE. SMR) GO TO 200
C   THE PROGRAM CAN ONLY HANDLEUP TO 7 MEMBERED RINGS
C   ABORT ALL LARGER RINGS
	IF(IT .GT. 7) GO TO 200
C   SEE IF ANY ATOM IN THIS RING IS NOT POSITIONED
	DO 950 I95=1,IT
	I96=TEMAR(I95)
	IF(AR(3,I96) .EQ. 0) GO TO 951
950	CONTINUE
C   ALL ATOMS POSITIONED
	GO TO 200
951	CONTINUE
C   RING IS SMALLER   SAVE IT
       SMR=IT
       DO 304 I32=1,IT
       SMRAR(I32)=TEMAR(I32)
304    CONTINUE
       GO TO 200
500    CONTINUE
C   POP THE STACK
       I2=I2-PC
       IC=PUSH1(I2)
       ID=PUSH1(I2+1)
       IT=PUSH1(I2+2)
       ICL=PUSH1(I2+3)
       IF(I2 .NE. 1) GO TO 200
600    CONTINUE
C   POPPED BACK TO BASE
       IF(SMR .EQ. 1000) GO TO 10
C   THERE IS A RING
C   FIRST ATOM IN RING MUST BE POSITIONED
       IF(AR(3,IC) .NE. 0) GO TO 606
C   MARK THIS RING AS A NON CENTRAL RING
       DO 607 I6=1,SMR
       I61=SMRAR(I6)
       ORING(I61)=ORC
607    CONTINUE
       ORC=ORC+1
       GO TO 10
606    CONTINUE
       I77=SMRAR(2)
       IF(AR(3,I77) .NE. 0) GO TO 77
C   SECOND ATOM OF RING NOT POSITIONED
       I78=SMRAR(SMR)
       IF(AR(3,I78) .EQ. 0) GO TO 77
C   LAST ATOM OF RING IS POSITIONED   REVERSE THE RING LIST
       DO 78 I79=SMR,2,-1
       SMRAR(I79)=SMRAR(I79-1)
78     CONTINUE
       SMRAR(1)=I78
77     CONTINUE
       CALL POSITION (SMR,SMRAR,MODE,RET)
C   IF NON CENTRAL RING CANT BE POSITIONED INCREASE LEG
	IF(RET .NE. 0) RETURN
C   ELIMINATE ATOMS IN RING WITH ONLY TWO RING NEIGHBORS
       DO 601 I6=1,SMR
       I61=SMRAR(I6)
       I63=0
       DO 602 I62=5,10
       I622=AR(I62,I61)
       IF(I622 .GT. 0 .AND. I622 .LT. 200) I63=I63+1
       IF(I622 .LT. 200) GO TO 602
C   PUT THIS BRANCH ON BRATAR
       I622=I622-200
       DO 6022 I6022=1,BRATC
       IF(BRATAR(I6022) .EQ. I622) GO TO 602
6022   CONTINUE
C   OK PUT IT ON
       BRATC=BRATC+1
       BRATAR(BRATC)=I622
602    CONTINUE
       IF(I63 .NE. 2) GO TO 601
C   ELIMINATE THIS ATOM
       AR(1,I61)=AR(1,I61)+100
       DO 603 I62=5,10
       I64=AR(I62,I61)
       IF(I64 .EQ. 0 .OR. I64 .GT. 100) GO TO 603
       AR(I62,I61)=I64+100
       DO 605 I65=5,10
       IF(AR(I65 ,I64) .EQ. I61) GO TO 6061
605    CONTINUE
       CALL WO ('R605')
6061   CONTINUE
       AR(I65,I64)=AR(I65,I64)+100
603    CONTINUE
601    CONTINUE
       GO TO 10
11     CONTINUE
       END
       SUBROUTINE BRANCH
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       COMMON /RECC/ RECCNT,RECLIM
       DATA RECLIM /300/
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
       RECCNT=0
       DO 9 I9=1,6
       REP=0
       DO 10 I1=1,NUMB
       IF(AR(3,I1) .NE. 0) GO TO 10
       DO 20 I2=5,10
       I3=AR(I2,I1)
       IF(I3 .EQ. 0) GO TO 21
       IF(I3 .GT. 100) I3=I3-100
       IF(I3 .GT. 100) I3=I3-100
       IF(AR(3,I3) .EQ. 0) GO TO 20
       CALL RECPOS (I3,I1,RET)
       IF(RECCNT .GE. RECLIM) RETURN
       REP=REP+RET
       GO TO 21
20     CONTINUE
21     CONTINUE
10     CONTINUE
       IF(REP .EQ. 0 .AND. I9 .NE. 1) GO TO 99
9      CONTINUE
99     CONTINUE
       END
       SUBROUTINE WO (I17)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
	COMMON /CREGNO/ REGNO
       COMMON /CPOSW/ POSW
	COMMON /CE2SW/ E2SW,E2CNT
	DATA E2SW /0/
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
     1   ER(6,100)
       COMMON /IO/ CID,COD,E2CID
	COMMON /CRPIC/ RHGH,RPIC(48)
	E2CNT=E2CNT+1
	IF(E2CNT .NE. 1) RETURN
	WRITE (E2CID,102) REGNO
102	FORMAT(1X,1I9)
	RHGH=1
	TYPE 108
108	FORMAT(' STRUCTURE CANT BE DISPLAYED')
30	CONTINUE
       DO 10 I1=1,NUMB
       DO 20 I2=10,5,-1
       IF(AR(I2,I1) .NE. 0) GO TO 21
20     CONTINUE
21     CONTINUE
	IJK=MOD(AR(1,I1),100)
	DO 930 I3=1,I2
	AR(I3,I1)=MOD(AR(I3,I1),100)
930	CONTINUE
       WRITE(5,101) IJK,AR(2,I1),(AR(I4,I1),I4=5,I2)
10     CONTINUE
101    FORMAT(1X,1I3,1X,1A2,1X,8I4)
	NUMB=0
	DO 50 I1=1,10
	AR(I1,1)=0
50	CONTINUE
       END
       SUBROUTINE POSITION (CNT,STR,MODE,RET)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       COMMON /FRDIR/ FRDIR
       DIMENSION RNGDIR(56)
       DATA (RNGDIR(I1),I1=1,56) /
     1  3,3,1,1,2,2,2,3,
     1 4,1,1,2,2,3,3,4,
     1 5,5,1,2,2,3,4,5,
     1 6,6,1,3,3,3,5,6,
     1 7,7,1,3,3,4,6,7,
     1   0,0,0,0,0,0,0,0,
     1   0,0,0,0,0,0,0,0/
       DIMENSION TSTR(20)
       COMMON /RNGGR/ RNGGR
       COMMON /STPOS/ STPOS
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
     1   ER(6,100)
       COMMON /REVT/ REVT(8)
       DATA (REVT(I1),I1=1,8)/ 5,6,7,8,1,2,3,4/
       DIMENSION STR(10)
       DIMENSION DIRT(140)
       DIMENSION T5(10,7),T6(12,7)
     1  ,T7(14,7),T3(12,7),T4(8,7)
       DATA (DIRT(I1),I1=1,140)/
     1  0,0,0,0,0,0,0,0,0,0,
     1  0,0,0,0,0,0,0,0,0,0,
     1  2,4,7,3,6,8,2,5,8,1,
     1  4,6,   0,0,0,0,0,0,0,0,
     1  1,3,5,7,2,4,6,8,   0,0,
     1  0,0,0,0,0,0,0,0,0,0,
     1  1,3,5,6,8,1,2,4,5,7,
     1  0,0,0,0,0,0,0,0,0,0,
     1  1,2,4,5,6,8,3,4,6,7,8,2,
     1  0,0,0,0,0,0,0,0,
     1  1,2,3,4,5,6,8,1,2,4,
     1  5,6,7,8,   0,0,0,0,0,0,
     1  0,0,0,0,0,0,0,0,0,0,
     1  0,0,0,0,0,0,0,0,0,0/
       DATA ((T3(I1,I2),I1=1,12),I2=1,7)    /
     1  5,6,4,3,1,2,12,10,11,8,9,7,
     1  7,8,2,4,5,6,7,1,6,3,8,5,
     1  4,5,2,10,7,8,4,1,8,3,5,7,
     1  5,6,7,10,2,3,5,1,3,4,6,5,
     1  12,14,3,13,2,4,12,1,4,5,14,2,
     1   0,0,0,0,0,0,0,0,0,0,0,0,
     1   0,0,0,0,0,0,0,0,0,0,0,0/
       DATA ((T4(I1,I2),I1=1,8 ),I2=1,7)    /
     1  8,3,4,10,5,6,1,2,
     1  3,4,1,2,7,8,6,5,
     1  3,10,1,2,4,5,7,8,
     1  4,10,1,7,5,6,2,3,
     1  5,13,1,3,12,14,2,4,
     1   0,0,0,0,0,0,0,0,
     1   0,0,0,0,0,0,0,0/
       DATA ((T5(I1,I2),I1=1,10),I2=1,7)    /
     1  8,3,10,1,2,8,5,6,10,4,
     1  3,4,1,5,6,3,7,8,1,2,
     1  3,10,1,7,8,3,4,5,1,2,
     1  4,10,1,2,3,4,5,6,1,7,
     1  5,13,1,2,4,5,12,14,1,3,
     1   0,0,0,0,0,0,0,0,0,0,
     1   0,0,0,0,0,0,0,0,0,0/
       DATA ((T6(I1,I2),I1=1,12),I2=1,7)    /
     1  8,5,6,10,1,2,3,6,1,4,2,5,
     1  3,7,8,1,5,6,4,8,5,2,6,7,
     1  3,4,5,1,7,8,10,5,7,2,8,4,
     1  4,5,6,1,2,3,10,11,12,7,8,9,
     1  5,12,14,1,2,4,13,14,2,3,4,12,
     1   0,0,0,0,0,0,0,0,0,0,0,0,
     1   0,0,0,0,0,0,0,0,0,0,0,0/
       DATA ((T7(I1,I2),I1=1,14),I2=1,7)    /
     1  8,5,3,6,10,1,2,8,5,6,10,1,4,2,
     1  3,7,4,8,1,5,6,3,7,8,1,5,2,6,
     1  3,4,10,5,1,7,8,3,4,5,1,7,2,8,
     1  4,5,10,6,1,2,3,4,5,6,1,2,7,3,
     1  5,12,13,14,1,9,10,5,6,7,1,2,3,4,
     1   0,0,0,0,0,0,0,0,0,0,0,0, 0,0,
     1   0,0,0,0,0,0,0,0,0,0,0,0, 0,0/
       DIMENSION LENT(140)
       DATA (LENT(I1),I1=1,140)/
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,2,2,1,1,1,2,1,2,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,2,1,1,1,1,1,1,1,2,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,2,1,1,2,2,1,2,2,
     1  1,1,2,1,1,1,1,1,1,1,
     1  1,1,1,1,1,1,1,1,1,1,
     1  1,1,1,1,1,1,1,1,1,1/
       COMMON /QSCALE/ SCALE
	RET=0
       IF(FRDIR .EQ. 0) GO TO 3000
       FD1=((CNT-3)*8)+FRDIR
       FRDIR=0
       NPH=RNGDIR(FD1)
       GO TO 1001
3000   CONTINUE
       IF(STPOS .NE. 0) GO TO 13
       STPOS=1
       ORCNT=6
       OPH=1
       GO TO 14
13     CONTINUE
       I1=STR(1)
       DO 10 I2=5,10
       IF(AR(I2,I1) .EQ. STR(2)) GO TO 11
10     CONTINUE
       CALL WO ('WE10')
11     CONTINUE
       ORCNT=BR(I2-4,I1)
       I97=STR(2)
       IF(ORCNT .GT. 100 .OR. AR(3,I97) .EQ. 0) GO TO 1002
       I99=STR(1)
       STR(1)=I97
       STR(2)=I99
       I95=3
       DO 1004 I96=CNT,3,-1
       TSTR(I95)=STR(I96)
       I95=I95+1
1004   CONTINUE
       DO 1003 I98=3,CNT
       STR(I98)=TSTR(I98)
1003   CONTINUE
1002   CONTINUE
       IF(ORCNT .GT. 100) ORCNT=ORCNT-100
       OPH=CR(I2-4,I1)
12     CONTINUE
14     CONTINUE
       GO TO (1,1,300,400,500,600,700,800,900),ORCNT
300    CONTINUE
       NPH=T3(OPH,CNT-2)
       GO TO 1000
400    CONTINUE
       NPH=T4(OPH,CNT-2)
       GO TO 1000
500    CONTINUE
       NPH=T5(OPH,CNT-2)
       GO TO 1000
600    CONTINUE
       NPH=T6(OPH,CNT-2)
       GO TO 1000
700    CONTINUE
       NPH=T7(OPH,CNT-2)
       GO TO 1000
1000   CONTINUE
       IF(MODE .EQ. 0) GO TO 1001
C   NON CENTRAL RING   USE PHASE 1
       NPH=1
1001   CONTINUE
       OFF=(CNT-2)*20
       QOFF=(((NPH-1)/  CNT)*  CNT)+1
       STR(CNT+1)=STR(1)
       DO 20 I3=1,CNT
       I4=DIRT(OFF+NPH)
       I5=STR(I3)
       I6=STR(I3+1)
       IF(AR(3,I6) .NE. 0) GO TO 2200
       LX=AR(3,I5)
       LY=AR(4,I5)
       GO TO (31,32,33,34,35,36,37,38),I4
31     CONTINUE
       DX=0
       DY=1
       GO TO 39
32     CONTINUE
       DX=1
       DY=1
       GO TO 39
33     CONTINUE
       DX=1
       DY=0
       GO TO 39
34     CONTINUE
       DX=1
       DY=-1
       GO TO 39
35     CONTINUE
       DX=0
       DY=-1
       GO TO 39
36     CONTINUE
       DX=-1
       DY=-1
       GO TO 39
37     CONTINUE
       DX=-1
       DY=0
       GO TO 39
38     CONTINUE
       DX=-1
       DY=1
       GO TO 39
39     CONTINUE
       IL=LENT(OFF+NPH)
       I92     =LX+(DX*SCALE*IL)
       I93     =LY+(DY*SCALE*IL)
       DO 2000 I91=1,NUMB
       IF(AR(3,I91) .NE. I92) GO TO 2000
       IF(I91 .EQ. I6) GO TO 2000
       IF(AR(4,I91) .NE. I93) GO TO 2000
C   NODE OVERLAP
C   IF NON CENTRAL RING OVERLAPS BALK
	IF(MODE .EQ. 0) GO TO 2002
	RET=1
	RETURN
2002	CONTINUE
       I92=I92-20
       I93=I93+20
       GO TO 2001
2000   CONTINUE
2001   CONTINUE
       AR(3,I6)=I92
       AR(4,I6)=I93
2200   CONTINUE
       DO 40 I7=5,10
       IF(AR(I7,I5) .EQ. I6) GO TO 41
40     CONTINUE
       CALL WO ('POS40')
41     CONTINUE
       BR(I7-4,I5)=CNT
       CR(I7-4,I5)=NPH
       ER(I7-4,I5)=I4
       DO 42 I8=5,10
       IF(AR(I8,I6) .EQ. I5) GO TO 43
42     CONTINUE
       CALL WO ('POS42')
43     CONTINUE
       BR(I8-4,I6)=CNT   +100
       CR(I8-4,I6)=NPH
       ER(I8-4,I6)=REVT(I4)
       NPH=NPH+1
       NPHT=MOD(NPH,CNT)
       IF(NPHT .EQ. 1  ) NPH=QOFF
20     CONTINUE
       IP=IP+1
       IF(RNGGR .EQ. 1)
     1 CALL GMOL (0)
       RETURN
800    CONTINUE
900    CONTINUE
1      CONTINUE
       CALL WO ('POEXT')
       END
       SUBROUTINE NDIRECT (I1,I2,I3,CNT,NDIR)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
	COMMON /CTERSE/ TERSE,TRING,TFRAG,NOPIC,ATHN,BENDARM
	DIMENSION BENDA(8)
	DATA (BENDA(I1),I1=1,8)/ 4,7,7,7,2,3,3,3/
       COMMON /IO/ CID,COD
       COMMON /REVT/ REVT(8)
       DIMENSION NDT(4,56)
       DATA ((NDT(I1,I2),I1=1,4),I2=1,56) /
     1  6,4,0,1,   8,2,0,5,   8,5,0,2,   1,6,0,4,   1,4,0,6,   5,2,0,8,
     1  2,4,0,7,   8,6,0,3,   6,3,0,8,   2,7,0,4,   7,4,0,2,   3,8,0,6,
     1  1,5,0,3,   5,1,0,7,   7,3,0,1,   3,7,0,5,
     1  4,8,0,2,   6,2,0,8,   2,6,0,4,   8,4,0,6,
     1  3,5,0,8,   5,7,0,2,   1,3,0,6,   1,7,0,4,
     1  1,3,7,5,   5,3,7,1,   1,5,3,7,   1,5,7,3,
     1  2,4,8,6,   2,6,8,4,   4,2,6,8,   4,8,6,2,
     1  2,5,8,1,  4,1,6,5,  3,6,8,7,  2,4,7,3,
     1  7,4,1,8, 3,5,8,6, 5,7,2,8,  1,3,6,4,
     1  1,4,5,7,  1,5,6,3,  1,5,8,3,  1,2,5,7,
     1  1,2,6,4,  2,6,7,4,  2,3,6,8,  2,5,6,8,
     1  1,4,8,6,  3,4,8,6,  4,5,8,2,  4,7,8,2,
     1  3,7,8,5,  3,6,7,1,  2,3,7,5,  3,4,7,1/
       NDIR=0
       IF(I2 .NE. 0) GO TO 12
       NDIR=REVT(I1)
	IF(BENDARM .EQ. 2) NDIR=BENDA(I1)
       GO TO 11
       RETURN
12     CONTINUE
       I41=1
       IF(I3 .NE. 0) I41=25
       DO 10 I4=I41,56
       CALL ND1(I1,I2,I3,NDT(1,I4),NDIR)
       IF(NDIR .NE. 0) GO TO 11
       IF(I4 .GE. 13 .AND. I4 .LE. 20) GO TO 10
       CALL ND1(I1,I3,I2,NDT(1,I4),NDIR)
       IF(NDIR .NE. 0) GO TO 11
       CALL ND1(I2,I1,I3,NDT(1,I4),NDIR)
       IF(NDIR .NE. 0) GO TO 11
       CALL ND1(I2,I3,I1,NDT(1,I4),NDIR)
       IF(NDIR .NE. 0) GO TO 11
       CALL ND1(I3,I1,I2,NDT(1,I4),NDIR)
       IF(NDIR .NE. 0) GO TO 11
       CALL ND1(I3,I2,I1,NDT(1,I4),NDIR)
       IF(NDIR .NE. 0) GO TO 11
10     CONTINUE
       CALL WO ('ND10')
C       WRITE(COD,101) I1,I2,I3
C101    FORMAT(1X,3I4)
       RETURN
11     CONTINUE
       IF(CNT .EQ. 0) GO TO 20
C   SAME DIRECTION GENERATED AGAIN
       IF(CNT .EQ. 1) NDIR=MOD(NDIR,8)+1
       IF(CNT .NE. 2) GO TO 30
       NDIR=NDIR-1
       IF(NDIR .EQ. 0) NDIR=8
30     CONTINUE
       IF(CNT .NE. 3) GO TO 40
       NDIR=MOD(NDIR,8)+1
       NDIR=MOD(NDIR,8)+1
40     CONTINUE
       IF(CNT .NE. 4) GO TO 50
       NDIR=NDIR-1
       IF(NDIR .EQ. 0) NDIR=8
       NDIR=NDIR-1
       IF(NDIR .EQ. 0) NDIR=8
50     CONTINUE
       RETURN
20     CONTINUE
       END
       SUBROUTINE ND1 (I1,I2,I3,QAR,NDIR)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       DIMENSION QAR(4)
       NDIR=0
       IF(I1 .EQ. QAR(1) .AND. I2 .EQ. QAR(2) .AND. I3 .EQ. QAR(3))
     1  NDIR=QAR(4)
       END
       SUBROUTINE INTERSECT (I1,I2,RET)
C-------------------------------------------------------------------------------
       REAL MM,QM,MC,QC,MX,MY,M1X,M1Y,M2X,M2Y,M3X,M3Y,M4X,M4Y,TT,TB
       IMPLICIT INTEGER (A-Z)
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
       RET=0
       I1X=AR(3,I1)
       I1Y=AR(4,I1)
       I2X=AR(3,I2)
       I2Y=AR(4,I2)
       MM=1000000.
	TT=I1Y-I2Y
	TB=I1X-I2X
       IF(I1X .NE. I2X) MM=TT/TB
       M1X=I1X
       M1Y=I1Y
       M2X=I2X
       M2Y=I2Y
       MC=M2Y-(MM*M2X)
       DO 10 I3=1,NUMB
       IF(I3 .EQ. I1 .OR. I3 .EQ. I2) GO TO 10
       I3X=AR(3,I3)
       IF(I3X .EQ. 0) GO TO 10
       I3Y=AR(4,I3)
       M3X=I3X
       M3Y=I3Y
       DO 20 I4=5,10
       I41=AR(I4,I3)
       IF(I41 .EQ. 0) GO TO 10
	IF(I41 .LT. I3) GO TO 20
       IF(I41 .GT. 100) I41=I41-100
       IF(I41 .GT. 100) I41=I41-100
       IF(I41 .EQ. I1 .OR. I41 .EQ. I2) GO TO 20
       I4X=AR(3,I41)
       IF(I4X .EQ. 0) GO TO 20
       I4Y=AR(4,I41)
C   GOT 4 POINTS
       QM=1000000.
	TT=I3Y-I4Y
	TB=I3X-I4X
       IF(I3X .NE. I4X)QM=TT/TB
       M4X=I4X
       M4Y=I4Y
       QC=M4Y-(QM*M4X)
      IF(QM.EQ.MM) GO TO 21
      MX=(QC-MC)/(MM-QM)
      IF((M1X-MX)*(MX-M2X).GE.0.AND.(M3X-MX)*(MX-M4X).GE.0) GO TO 60
      GO TO 20
21    IF(MC.NE.QC) GO TO 20
      IF(ABS(QM).GT.1.0) GO TO 22
      IF((M1X-M3X)*(M3X-M2X).GE.0.OR.(M1X-M4X)*(M4X-M2X).GE.0)GOTO60
      GO TO 20
22    	CONTINUE
	IF((M1Y-M3Y)*(M3Y-M2Y).GE.0.OR.(M1Y-M4Y)*(M4Y-M2Y).GE.0) GO TO 60
20     CONTINUE
10     CONTINUE
       RETURN
60     CONTINUE
       RET=1
       END
       SUBROUTINE RECPOS (LAT,NAT,RET)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       COMMON /REVT/ REVT(8)
       COMMON /FRDIR/ FRDIR
       COMMON /QSCALE/ SCALE
       COMMON /RECC/ RECCNT,RECLIM
       COMMON /PUSLIM/ P1LIM,P2LIM,P3LIM
       COMMON /PUSH/ PUSH1(1000),PUSH2(2000),PUSH3(300)
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100),
     1   ER(6,100)
       COMMON /OTHRING/ ORC,ORING(100)
       DIMENSION NDAR(3)
       PL=12
       IP3=1
       I2=10
       LC=LAT
       NC=NAT
600    CONTINUE
       IF(I2 .LE. P2LIM) GO TO 5051
       TYPE 5052
       RECCNT=1000000
       RETURN
5052   FORMAT(' PUSH2 OVERFLOW'/)
5051   CONTINUE
       DISC=0
       DIRC=0
       RNGSW=1
       RNG=0
       RET=0
400    CONTINUE
C   BEGIN TO POSITION THIS ATOM
C   ASSUMES THAT NEIGHBORS ARE ORDERED ACCORDING TO LENGTH
       NDAR(1)=0
       NDAR(2)=0
       NDAR(3)=0
       I41=1
       DO 401 I4=5,10
       I42=AR(I4,LC)
       IF(I42 .EQ. 0) GO TO 4205
       IF(I42 .GT. 100) I42=I42-100
       IF(I42 .GT. 100) I42=I42-100
       IF(AR(3,I42) .EQ. 0) GO TO 401
C   FOUND A NEIGHBOR ON LAT WHICH IS POSITIONED
       NDAR(I41)=ER(I4-4,LC)
       I41=I41+1
401    CONTINUE
4205   CONTINUE
       IF(I41 .NE. 1) GO TO 420
C   NO NEIGHBORS ARE SET  USE DIRECTION 3
       NDIR=3
       GO TO 471
420    CONTINUE
       CALL NDIRECT (NDAR(1),NDAR(2),NDAR(3),DIRC,NDIR)
471    CONTINUE
       RECCNT=RECCNT+1
       IF(RECCNT .GE. RECLIM) RETURN
C   CHANGE LENGTH OF ARM
       DISC=DISC+1
       IF(DISC .LE.  5) GO TO 410
470    CONTINUE
C   CHANGE DIRECTION
       DISC=0
       DIRC=DIRC+1
       IF(DIRC .GE. 4) GO TO 502
C   CLEAR POSITIONING OF ATOM
       AR(3,NC)=0
       AR(4,NC)=0
       NCP1=NC+100
       NCP2=NC+200
       DO 531 I431=5,10
       I432=AR(I431,LC)
       IF(I432 .EQ. NC .OR. I432 .EQ. NCP1 .OR. I432 .EQ. NCP2)
     1  GO TO 532
531    CONTINUE
       CALL WO ('RP531')
532    CONTINUE
       ER(I431-4,LC)=0
       LCP1=LC+100
       LCP2=LC+200
       DO 533 I433=5,10
       I434=AR(I433,NC)
       IF( I434 .EQ. LC .OR. I434 .EQ. LCP1 .OR. I434 .EQ. LCP2)
     1  GO TO 534
533    CONTINUE
       CALL WO ('RP533')
534    CONTINUE
       ER(I433-4,NC)=0
       I411X=AR(3,NC)
       I411Y=AR(4,NC)
       GO TO 420
410    CONTINUE
       GO TO (411,412,413,414,415,416,417,418),NDIR
411    CONTINUE
       AR(3,NC)=AR(3,LC)
       AR(4,NC)=AR(4,LC)+(DISC*SCALE)
       GO TO 430
412    CONTINUE
       AR(3,NC)=AR(3,LC)+(DISC*SCALE)
       AR(4,NC)=AR(4,LC)+(DISC*SCALE)
       GO TO 430
413    CONTINUE
       AR(3,NC)=AR(3,LC)+(DISC*SCALE)
       AR(4,NC)=AR(4,LC)
       GO TO 430
414    CONTINUE
       AR(3,NC)=AR(3,LC)+(DISC*SCALE)
       AR(4,NC)=AR(4,LC)-(DISC*SCALE)
       GO TO 430
415    CONTINUE
       AR(3,NC)=AR(3,LC)
       AR(4,NC)=AR(4,LC)-(DISC*SCALE)
       GO TO 430
416    CONTINUE
       AR(3,NC)=AR(3,LC)-(DISC*SCALE)
       AR(4,NC)=AR(4,LC)-(DISC*SCALE)
       GO TO 430
417    CONTINUE
       AR(3,NC)=AR(3,LC)-(DISC*SCALE)
       AR(4,NC)=AR(4,LC)
       GO TO 430
418    CONTINUE
       AR(3,NC)=AR(3,LC)-(DISC*SCALE)
       AR(4,NC)=AR(4,LC)+(DISC*SCALE)
       GO TO 430
430    CONTINUE
       IF(I411X .EQ. 0 .OR. (I411X .EQ. AR(3,NC) .AND.
     1  I411Y .EQ. AR(4,NC))) GO TO 4119
C       WRITE(COD,4118) I411X,I411Y,AR(3,NC),AR(4,NC)
C4118   FORMAT(' OLD ',2I5,' NEW ',2I5)
       AR(3,NC)=I411X
       AR(4,NC)=I411Y
4119   CONTINUE
       CALL INTERSECT (LC,NC,RET)
       IF(RET .NE. 1) GO TO 4717
       AR(3,NC)=0
       AR(4,NC)=0
       GO TO 470
4717   CONTINUE
       NCP1=NC+100
       NCP2=NC+200
       DO 431 I431=5,10
       I432=AR(I431,LC)
       IF(I432 .EQ. NC .OR. I432 .EQ. NCP1 .OR. I432 .EQ. NCP2)
     1  GO TO 432
431    CONTINUE
       CALL WO ('RP431')
432    CONTINUE
       ER(I431-4,LC)=NDIR
       LCP1=LC+100
       LCP2=LC+200
       DO 433 I433=5,10
       I434=AR(I433,NC)
       IF( I434 .EQ. LC .OR. I434 .EQ. LCP1 .OR. I434 .EQ. LCP2)
     1  GO TO 434
433    CONTINUE
       CALL WO ('RP433')
434    CONTINUE
       ER(I433-4,NC)=REVT(NDIR)
       IF(ORING(NC) .EQ. 0) GO TO 480
	IF(DISC .LT. 2) GO TO 471
C   NON CENTRAL RING
       FRDIR=NDIR
       CALL RINGGG (NC,PUSH3(IP3),RNG,RET)
       IF(RET .EQ. 1) GO TO 470
       I5=0
       RNGSW=2
540    CONTINUE
       I5=I5+1
       IF(I5 .GT. RNG) GO TO 500
       I55=PUSH3(IP3+I5-1)
       DO 541 I54=5,10
       I51=AR(I54,I55)
       IF(I51 .EQ. 0) GO TO 540
       IF(I51 .LE. 200) GO TO 541
       I51=I51-200
       IF(AR(3,I51) .NE. 0) GO TO 542
541    CONTINUE
       CALL WO ('RP541')
542    CONTINUE
C   SAVE THIS ATOM
       PUSH2(I2)=LC
       PUSH2(I2+1)=NC
       PUSH2(I2+2)=DISC
       PUSH2(I2+3)=DIRC
       PUSH2(I2+4)=I5
       PUSH2(I2+5)=RNG
       PUSH2(I2+6)=IP3
       PUSH2(I2+7)=RNGSW
       PUSH2(I2+8)=I51
       PUSH2(I2+9)=NDAR(1)
       PUSH2(I2+10)=NDAR(2)
       PUSH2(I2+11)=NDAR(3)
       IP3=IP3+RNG
       IF(IP3 .LE. P3LIM) GO TO 5055
       TYPE 5056
       RECCNT=1000000
       RETURN
5056   FORMAT(' PUSH3 OVERFLOW'/)
5055   CONTINUE
       I2=I2+PL
       LC=I51
       NC=I55
       GO TO 600
480    CONTINUE
       I5=4
440    CONTINUE
       I5=I5+1
       IF(I5 .GT. 10) GO TO 500
       I51=AR(I5,NC)
       IF(I51 .LT. 200) GO TO 440
       I51=I51-200
       IF(AR(3,I51) .NE. 0) GO TO 440
C   SAVE THIS ATOM
       PUSH2(I2)=LC
       PUSH2(I2+1)=NC
       PUSH2(I2+2)=DISC
       PUSH2(I2+3)=DIRC
       PUSH2(I2+4)=I5
       PUSH2(I2+5)=RNG
       PUSH2(I2+6)=IP3
       PUSH2(I2+7)=RNGSW
       PUSH2(I2+8)=I51
       PUSH2(I2+9)=NDAR(1)
       PUSH2(I2+10)=NDAR(2)
       PUSH2(I2+11)=NDAR(3)
       I2=I2+PL
       LC=NC
       NC=I51
       GO TO 600
502    CONTINUE
       RET=1
500    CONTINUE
       I2=I2-PL
       IF(I2 .LE. 1) GO TO 700
       LC=PUSH2(I2)
       NC=PUSH2(I2+1)
       DISC=PUSH2(I2+2)
       DIRC=PUSH2(I2+3)
       I5=PUSH2(I2+4)
       RNG=PUSH2(I2+5)
       IP3=PUSH2(I2+6)
       RNGSW=PUSH2(I2+7)
       I51=PUSH2(I2+8)
       NDAR(1)=PUSH2(I2+9 )
       NDAR(1)=PUSH2(I2+10)
       NDAR(1)=PUSH2(I2+11)
       IF(RET .EQ. 0) GO TO 501
       RET=0
       CALL UNPOS (NC)
       GO TO 471
501    CONTINUE
       GO TO (440,540),RNGSW
700    CONTINUE
       END
       SUBROUTINE UNPOS (NC)
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
       COMMON /PUSH4/ PUSH4(100)
       IP4=2
       PUSH4(1)=NC
       PUSH4(2)=0
       DO 10 PP4=1,100
       PN=PUSH4(PP4)
       IF(PN .EQ. 0) GO TO 11
       AR(3,PN)=0
       AR(4,PN)=0
       DO 20 I1=5,10
       I2=AR(I1,PN)
       IF(I2 .EQ. 0 .OR. DR(I1-4,PN) .EQ. 0) GO TO 20
       IF(I2 .GT. 100) I2=I2-100
       IF(I2 .GT. 100) I2=I2-100
       IF(AR(3,I2) .EQ. 0) GO TO 20
       PUSH4(IP4)=I2
       PUSH4(IP4+1)=0
       IP4=IP4+1
20     CONTINUE
10     CONTINUE
11     CONTINUE
       END
       SUBROUTINE ELIMEND
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       DIMENSION TAR1(10),TAR2(10)
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
       DO 60 I1=1,NUMB
       IF(AR(6,I1) .NE. 0) GO TO 60
C    ONLY ONE ATTACHMENT
       I2=AR(5,I1)
       DO 61 I3=5,10
       IF(AR(I3,I2) .EQ. I1) GO TO 62
61     CONTINUE
       CALL WO ('EE60')
62     CONTINUE
       DR(I3,I2)=1
       AR(1,I1)=AR(1,I1)+200
60     CONTINUE
40     CONTINUE
       FND=0
       DO 10 I1=NUMB,1,-1
       IF(AR(1,I1) .GT. 100) GO TO 10
       I3=0
       DO 20 I2=5,10
       IF(AR(I2,I1) .EQ. 0) GO TO 20
       IF(AR(I2,I1) .GT. 200) GO TO 20
       I3=I3+1
       I4=AR(I2,I1)
       I41=I2
20     CONTINUE
       IF(I3 .GT. 1 .OR. I3 .EQ. 0) GO TO 10
       AR(I41,I1)=AR(I41,I1)+200
       FND=1
       I8=0
       DO 400 I9=1,6
       IF(DR(I9,I1) .GT. I8) I8=DR(I9,I1)
400    CONTINUE
       DO 30 I2=5,10
       IF(AR(I2,I4) .EQ. I1) GO TO 31
30     CONTINUE
       CALL WO ('EE30')
31     CONTINUE
       AR(I2,I4)=AR(I2,I4)+200
       AR(1,I1)=AR(1,I1)+200
       DR(I2-4,I4)=I8+1
10     CONTINUE
       IF(FND .EQ. 1) GO TO 40
       DO 50 I1=1,NUMB
       IF(AR(1,I1) .LT. 200) GO TO 50
51     CONTINUE
       I5=1
       DO 95 I2=1,6
	TAR1(I2)=0
	TAR2(I2)=0
       IF(AR(I2+4,I1) .EQ. 0 .OR. DR(I2,I1) .NE. 0 ) GO TO 95
       TAR1(I5)=DR(I2,I1)
       TAR2(I5)=AR(I2+4,I1)
       I5=I5+1
95     CONTINUE
       DO 80 I2=1,6
       I4=0
       DO 70 I3=1,6
       IF(DR(I3,I1) .LE. TAR1(I2)) GO TO 70
       TAR1(I5)=DR(I3,I1)
       TAR2(I5)=AR(I3+4,I1)
       I4=I3
70     CONTINUE
       IF(I4 .EQ. 0) GO TO 81
       DR(I4,I1)=-1
       I5=I5+1
80     CONTINUE
81    CONTINUE
       DO 90 I2=1,6
       AR(I2+4,I1)=TAR2(I2)
       DR(I2,I1)=TAR1(I2)
90     CONTINUE
50     CONTINUE
       END
       SUBROUTINE SAFMAF
C-------------------------------------------------------------------------------
       IMPLICIT INTEGER (A-Z)
       DIMENSION STPAR(12)
       DATA (STPAR(I1),I1=1,12) /500,500,700,700,300,300
     1  ,700,300,300,700,300,500/
       COMMON /CASA/ NUMB,AR(10,100),BR(6,100),CR(6,100),DR(6,100)
       COMMON /PUSH4/ PUSH4(100)
       STC=1
       DO 30 I3=1,NUMB
       IF(AR(3,I3) .NE. 0 .AND. I3 .NE. 1) GO TO 30
       AR(3,I3)=STPAR(STC)
       AR(4,I3)=STPAR(STC+1)
       STC=STC+2
       IP4=2
       PUSH4(1)=I3
       PUSH4(2)=0
       DO 10 PP4=1,100
       PN=PUSH4(PP4)
       IF(PN .EQ. 0) GO TO 11
       DO 20 I1=5,10
       I2=AR(I1,PN)
       IF(I2 .EQ. 0) GO TO 20
       IF(AR(3,I2) .NE. 0) GO TO 20
       AR(3,I2)=AR(3,I2)-1
       PUSH4(IP4)=I2
       PUSH4(IP4+1)=0
       IP4=IP4+1
20     CONTINUE
10     CONTINUE
11     CONTINUE
30     CONTINUE
       DO 40 I1=1,NUMB
       AR(3,I1)=AR(3,I1)+1
40     CONTINUE
       END
	SUBROUTINE NMORGAN 
	IMPLICIT INTEGER (A-Z)
	COMMON /CASA/ NUMB,AR(1000)
       COMMON /IO/ CID,COD,FILSIZ,ICNT
	COMMON /CPOSW/ POSW
	COMMON /NMOR/ NN(100),EV(100),PST(100),SA(100)
     1  ,Z(2,100),ATS(100),AT(100),ASS(100)
     1  ,SUBQ(100),SUBS(100),SUBT(100)
	DIMENSION ZS(2)
	EQUIVALENCE (ZS(1),Z(1,1))
	I11=0
	DO 10 I1=1,NUMB
	DO 20 I2=5,10
	IF(AR(I2+I11) .EQ. 0) GO TO 21
20	CONTINUE
	I2=11
21	CONTINUE
	AT(I1)=AR(2+I11)
	I2=I2-5
	NN(I1)=I2
	EV(I1)=I2
	SA(I1)=I2
	I11=I11+10
10	CONTINUE
	OK=0
30	CONTINUE
	CALL SORT (SA,NUMB,1)
	NK=1
	I2=SA(1)
	PST(1)=EV(1)
	DO 50 I1=2,NUMB
	PST(I1)=EV(I1)
	IF(SA(I1) .EQ. I2) GO TO 50
	NK=NK+1
	I2=SA(I1)
50	CONTINUE
	IF(NK .LE. OK) GO TO 51
	OK=NK
	I11=0
	DO 60 I1=1,NUMB
	I2=NN(I1)
	I5=0
	IF(I2 .EQ. 0) GO TO 72
	DO 70 I3=1,I2
	I4=AR(I3+4+I11)
	IF(I4 .GE. 1 .AND. I4 .LE. 100) GO TO 71
	TYPE 101,I1,I2
101	FORMAT(' NMORGAN ',2I3/)
	RETURN
71	CONTINUE
	I5=I5+PST(I4)
70	CONTINUE
72	CONTINUE
	EV(I1)=I5
	SA(I1)=I5
	I11=I11+10
60	CONTINUE
	GO TO 30
51	CONTINUE
	IF(POSW .NE. 0) GO TO 89
	KUMB=(NUMB*10)
	WRITE (COD,102)(AR(I111),I111=1,KUMB,10)
	WRITE(COD,102)(EV(I111),I111=1,NUMB)
102	FORMAT(1X,30I4)
	WRITE(COD,102)(SA(I111),I111=1,NUMB)
89	CONTINUE
	DO 82 I1=1,NUMB
	ATS(I1)=0
82	CONTINUE
	I13=SA(NUMB)
	DO 90 I1=NUMB,1,-1
	IF(EV(I1) .NE. I13) GO TO 90
	DO 80 I2=1,NUMB
	PST(I2)=0
80	CONTINUE
	I2=0
	I3=1
	SA(1)=I1
120	CONTINUE
	I2=I2+1
	IF(I2 .GT. I3) GO TO 121
	I4=SA(I2)
	I44=(I4-1)*10
	I5=NN(I4)
	IF(I5 .EQ. 0) GO TO 132
	K6=0
	DO 100 I6=1,I5
	I7=AR(I6+4+I44)
	ZS(3+K6)=I7
	ZS(1+K6)=EV(I7)
	ZS(2+K6)=AT(I7)
	K6=K6+3
100	CONTINUE
	CALL SORT (Z,I5,3)
	K6=(I5-1)*3
	DO 110 I6=I5,1,-1
	I8=ZS(3+K6)
	DO 130 I7=1,I3
	IF(I8 .EQ. SA(I7)) GO TO 131
130	CONTINUE
132	CONTINUE
	I3=I3+1
	SA(I3)=I8
	PST(I3)=AT(I8)
	IF(AT(I8) .LT. ATS(I3)) GO TO 90
C   THE ATOM SEQUENCE OF DEVELOPING STRUCTURE IS GTE
	IF(AT(I8) .EQ. ATS(I3)) GO TO 138
131	CONTINUE
	DO 139 I18=1,NUMB
	ATS(I18)=0
139	CONTINUE
138	CONTINUE
	K6=K6-3
110	CONTINUE
	GO TO 120
121	CONTINUE
	DO 140 I2=1,NUMB
	ATS(I2)=PST(I2)
	ASS(I2)=SA(I2)
140	CONTINUE
	I11=I1
90	CONTINUE
	DO 150 I1=1,NUMB
	Z(2,I1)=I1
	Z(1,I1)=ASS(I1)
150	CONTINUE
	CALL SORT (Z,NUMB,2)
	IF(POSW .EQ. 0)
     1  WRITE(COD,102)(Z(1,I111),Z(2,I111),I111=1,NUMB)
	I11=0
	DO 160 I1=1,NUMB
	I2=NN(I1)
	DO 170 I3=1,I2
	I4=AR(I3+4+I11)
	AR(I3+4+I11)=Z(2,I4)
170	CONTINUE
	AR(1+I11)=Z(2,I1)
	IF(I2 .GT. 1) CALL SORT (AR(5+I11),I2,1)
	I11=I11+10
160	CONTINUE
	CALL SORT (AR,NUMB,10)
C	IF(POSW .EQ. 0) CALL PRAR (AR,NUMB,'NMORG')
	END